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

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

CLOSE message: close document before invoking SUPER method, not after.
Insertion/deletion fixes.

  • 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
438(defloadvar *modeline-text-attributes* nil)
439
440(def-cocoa-default *modeline-font-name* :string "Courier New Bold Italic")
441(def-cocoa-default  *modeline-font-size* :float 10.0)
442
443
444;;; Find the underlying buffer.
445(defun buffer-for-modeline-view (mv)
446  (let* ((pane (modeline-view-pane mv)))
447    (unless (%null-ptr-p pane)
448      (let* ((tv (text-pane-text-view pane)))
449        (unless (%null-ptr-p tv)
450          (text-view-buffer tv))))))
451
452;;; Draw a string in the modeline view.  The font and other attributes
453;;; are initialized lazily; apparently, calling the Font Manager too
454;;; early in the loading sequence confuses some Carbon libraries that're
455;;; used in the event dispatch mechanism,
456(defun draw-modeline-string (modeline-view)
457  (let* ((pane (modeline-view-pane modeline-view))
458         (buffer (buffer-for-modeline-view modeline-view)))
459    (when buffer
460      ;; You don't want to know why this is done this way.
461      (unless *modeline-text-attributes*
462        (setq *modeline-text-attributes*
463              (create-text-attributes :color (send (@class "NSColor") 'black-color)
464                                      :font (default-font
465                                              :name *modeline-font-name*
466                                              :size *modeline-font-size*))))
467     
468      (let* ((string
469              (apply #'concatenate 'string
470                     (mapcar
471                      #'(lambda (field)
472                          (funcall (hi::modeline-field-function field)
473                                   buffer pane))
474                      (hi::buffer-modeline-fields buffer)))))
475        (send (%make-nsstring string)
476              :draw-at-point (ns-make-point 0.0f0 0.0f0)
477              :with-attributes *modeline-text-attributes*)))))
478
479;;; Draw the underlying buffer's modeline string on a white background
480;;; with a bezeled border around it.
481(define-objc-method ((:void :draw-rect (:<NSR>ect rect)) 
482                     modeline-view)
483  (declare (ignore rect))
484  (slet ((frame (send self 'bounds)))
485     (#_NSDrawWhiteBezel frame frame)
486     (draw-modeline-string self)))
487
488;;; Hook things up so that the modeline is updated whenever certain buffer
489;;; attributes change.
490(hi::%init-mode-redisplay)
491
492
493;;; Modeline-scroll-view
494
495;;; This is just an NSScrollView that draws a "placard" view (the modeline)
496;;; in the horizontal scrollbar.  The modeline's arbitrarily given the
497;;; leftmost 75% of the available real estate.
498(defclass modeline-scroll-view (ns:ns-scroll-view)
499    ((modeline :foreign-type :id :accessor scroll-view-modeline)
500     (pane :foreign-type :id :accessor scroll-view-pane))
501  (:metaclass ns:+ns-object))
502
503;;; Making an instance of a modeline scroll view instantiates the
504;;; modeline view, as well.
505
506(define-objc-method ((:id :init-with-frame (:<NSR>ect frame))
507                     modeline-scroll-view)
508    (let* ((v (send-super :init-with-frame frame)))
509      (when v
510        (let* ((modeline (make-objc-instance 'modeline-view)))
511          (send v :add-subview modeline)
512          (setf (scroll-view-modeline v) modeline)))
513      v))
514
515;;; Scroll views use the "tile" method to lay out their subviews.
516;;; After the next-method has done so, steal some room in the horizontal
517;;; scroll bar and place the modeline view there.
518
519(define-objc-method ((:void tile) modeline-scroll-view)
520  (send-super 'tile)
521  (let* ((modeline (scroll-view-modeline self)))
522    (when (and (send self 'has-horizontal-scroller)
523               (not (%null-ptr-p modeline)))
524      (let* ((hscroll (send self 'horizontal-scroller)))
525        (slet ((scrollbar-frame (send hscroll 'frame))
526               (modeline-frame (send hscroll 'frame))) ; sic
527           (let* ((modeline-width (* (pref modeline-frame
528                                           :<NSR>ect.size.width)
529                                     0.75e0)))
530             (declare (single-float modeline-width))
531             (setf (pref modeline-frame :<NSR>ect.size.width)
532                   modeline-width
533                   (the single-float
534                     (pref scrollbar-frame :<NSR>ect.size.width))
535                   (- (the single-float
536                        (pref scrollbar-frame :<NSR>ect.size.width))
537                      modeline-width)
538                   (the single-float
539                     (pref scrollbar-frame :<NSR>ect.origin.x))
540                   (+ (the single-float
541                        (pref scrollbar-frame :<NSR>ect.origin.x))
542                      modeline-width))
543             (send hscroll :set-frame scrollbar-frame)
544             (send modeline :set-frame modeline-frame)))))))
545
546
547;;; Text-pane
548
549;;; The text pane is just an NSBox that (a) provides a draggable border
550;;; around (b) encapsulates the text view and the mode line.
551
552(defclass text-pane (ns:ns-box)
553    ((text-view :foreign-type :id :accessor text-pane-text-view)
554     (mode-line :foreign-type :id :accessor text-pane-mode-line)
555     (scroll-view :foreign-type :id :accessor text-pane-scroll-view))
556  (:metaclass ns:+ns-object))
557
558;;; Mark the pane's modeline as needing display.  This is called whenever
559;;; "interesting" attributes of a buffer are changed.
560
561(defun hi::invalidate-modeline (pane)
562  (send (text-pane-mode-line pane) :set-needs-display t))
563
564(define-objc-method ((:id :init-with-frame (:<NSR>ect frame))
565                     text-pane)
566    (let* ((pane (send-super :init-with-frame frame)))
567      (unless (%null-ptr-p pane)
568        (send pane :set-autoresizing-mask (logior
569                                           #$NSViewWidthSizable
570                                           #$NSViewHeightSizable))
571        (send pane :set-box-type #$NSBoxPrimary)
572        (send pane :set-border-type #$NSLineBorder)
573        (send pane :set-title-position #$NSNoTitle))
574      pane))
575
576
577(defun make-scrolling-text-view-for-textstorage (textstorage x y width height)
578  (slet ((contentrect (ns-make-rect x y width height)))
579    (let* ((scrollview (send (make-objc-instance
580                              'modeline-scroll-view
581                              :with-frame contentrect) 'autorelease)))
582      (send scrollview :set-border-type #$NSBezelBorder)
583      (send scrollview :set-has-vertical-scroller t)
584      (send scrollview :set-has-horizontal-scroller t)
585      (send scrollview :set-rulers-visible nil)
586      (send scrollview :set-autoresizing-mask (logior
587                                               #$NSViewWidthSizable
588                                               #$NSViewHeightSizable))
589      (send (send scrollview 'content-view) :set-autoresizes-subviews t)
590      (let* ((layout (make-objc-instance 'ns-layout-manager)))
591        (send textstorage :add-layout-manager layout)
592        (send layout 'release)
593        (slet* ((contentsize (send scrollview 'content-size))
594                (containersize (ns-make-size
595                                1.0f7
596                                1.0f7))
597                (tv-frame (ns-make-rect
598                           0.0f0
599                           0.0f0
600                           (pref contentsize :<NSS>ize.width)
601                           (pref contentsize :<NSS>ize.height))))
602          (let* ((container (send (make-objc-instance
603                                   'ns-text-container
604                                   :with-container-size containersize)
605                                  'autorelease)))
606            (send layout :add-text-container container)
607            (let* ((tv (send (make-objc-instance 'hemlock-text-view
608                                                 :with-frame tv-frame
609                                                 :text-container container)
610                             'autorelease)))
611              (send tv :set-min-size (ns-make-size
612                                      0.0f0
613                                      (pref contentsize :<NSS>ize.height)))
614              (send tv :set-max-size (ns-make-size 1.0f7 1.0f7))
615              (send tv :set-rich-text nil)
616              (send tv :set-horizontally-resizable t)
617              (send tv :set-vertically-resizable t) 
618              (send tv :set-autoresizing-mask #$NSViewWidthSizable)
619              (send container :set-width-tracks-text-view nil)
620              (send container :set-height-tracks-text-view nil)
621              (send scrollview :set-document-view tv)         
622              (values tv scrollview))))))))
623
624(defun make-scrolling-textview-for-pane (pane textstorage)
625  (slet ((contentrect (send (send pane 'content-view) 'frame)))
626    (multiple-value-bind (tv scrollview)
627        (make-scrolling-text-view-for-textstorage
628         textstorage
629         (pref contentrect :<NSR>ect.origin.x)
630         (pref contentrect :<NSR>ect.origin.y)
631         (pref contentrect :<NSR>ect.size.width)
632         (pref contentrect :<NSR>ect.size.height))
633      (send pane :set-content-view scrollview)
634      (setf (slot-value pane 'scroll-view) scrollview
635            (slot-value pane 'text-view) tv
636            (slot-value tv 'pane) pane
637            (slot-value scrollview 'pane) pane)
638      (let* ((modeline  (scroll-view-modeline scrollview)))
639        (setf (slot-value pane 'mode-line) modeline
640              (slot-value modeline 'pane) pane))
641      tv)))
642
643
644(defmethod hemlock-frame-command-info ((w ns:ns-window))
645  nil)
646
647
648(defclass hemlock-frame (ns:ns-window)
649    ((command-info :initform (hi::make-command-interpreter-info)
650                   :accessor hemlock-frame-command-info))
651  (:metaclass ns:+ns-object))
652
653
654(defmethod shared-initialize :after ((w hemlock-frame)
655                                     slot-names
656                                     &key &allow-other-keys)
657  (declare (ignore slot-names))
658  (let ((info (hemlock-frame-command-info w)))
659    (when info
660      (setf (hi::command-interpreter-info-frame info) w))))
661
662
663(defun get-cocoa-window-flag (w flagname)
664  (case flagname
665    (:accepts-mouse-moved-events
666     (send w 'accepts-mouse-moved-events))
667    (:cursor-rects-enabled
668     (send w 'are-cursor-rects-enabled))
669    (:auto-display
670     (send w 'is-autodisplay))))
671
672
673
674(defun (setf get-cocoa-window-flag) (value w flagname)
675  (case flagname
676    (:accepts-mouse-moved-events
677     (send w :set-accepts-mouse-moved-events value))
678    (:auto-display
679     (send w :set-autodisplay value))))
680
681
682
683(defun activate-window (w)
684  ;; Make w the "key" and frontmost window.  Make it visible, if need be.
685  (send w :make-key-and-order-front nil))
686
687(defun new-hemlock-document-window (&key
688                                    (x 200.0)
689                                    (y 200.0)
690                                    (height 200.0)
691                                    (width 500.0)
692                                    (closable t)
693                                    (iconifyable t)
694                                    (metal t)
695                                    (expandable t)
696                                    (backing :buffered)
697                                    (defer nil)
698                                    (accepts-mouse-moved-events nil)
699                                    (auto-display t)
700                                    (activate t))
701  (rlet ((frame :<NSR>ect :origin.x (float x) :origin.y (float y) :size.width (float width) :size.height (float height)))
702    (let* ((stylemask
703            (logior #$NSTitledWindowMask
704                    (if closable #$NSClosableWindowMask 0)
705                    (if iconifyable #$NSMiniaturizableWindowMask 0)
706                    (if expandable #$NSResizableWindowMask 0)
707                    (if metal #$NSTexturedBackgroundWindowMask 0)))
708           (backing-type
709            (ecase backing
710              ((t :retained) #$NSBackingStoreRetained)
711              ((nil :nonretained) #$NSBackingStoreNonretained)
712              (:buffered #$NSBackingStoreBuffered)))
713           (w (make-instance
714               'hemlock-frame
715               :with-content-rect frame
716               :style-mask stylemask
717               :backing backing-type
718               :defer defer)))
719      (setf (get-cocoa-window-flag w :accepts-mouse-moved-events)
720            accepts-mouse-moved-events
721            (get-cocoa-window-flag w :auto-display)
722            auto-display)
723      (when activate (activate-window w))
724      (values w (add-pane-to-window w :reserve-below 20.0)))))
725
726
727
728(defun add-pane-to-window (w &key (reserve-above 0.0f0) (reserve-below 0.0f0))
729  (let* ((window-content-view (send w 'content-view)))
730    (slet ((window-frame (send window-content-view 'frame)))
731      (slet ((pane-rect (ns-make-rect 0.0f0
732                                      reserve-below
733                                      (pref window-frame :<NSR>ect.size.width)
734                                      (- (pref window-frame :<NSR>ect.size.height) (+ reserve-above reserve-below)))))
735        (let* ((pane (make-objc-instance 'text-pane :with-frame pane-rect)))
736          (send window-content-view :add-subview pane)
737          pane)))))
738
739
740         
741                                       
742                                     
743(defun textpane-for-textstorage (ts)
744  (let* ((pane (nth-value
745                1
746                (new-hemlock-document-window :activate nil)))
747         (tv (make-scrolling-textview-for-pane pane ts)))
748    (multiple-value-bind (height width)
749        (size-of-char-in-font (default-font))
750      (size-textview-containers tv height width 24 80))
751    pane))
752
753
754(defun read-file-to-hemlock-buffer (path)
755  (hemlock::find-file-buffer path))
756
757(defun hemlock-buffer-from-nsstring (nsstring name &rest modes)
758  (let* ((buffer (make-hemlock-buffer name :modes modes)))
759    (nsstring-to-buffer nsstring buffer)))
760
761(defun nsstring-to-buffer (nsstring buffer)
762  (let* ((document (hi::buffer-document buffer)))
763    (setf (hi::buffer-document buffer) nil)
764    (unwind-protect
765         (progn
766           (hi::delete-region (hi::buffer-region buffer))
767           (hi::modifying-buffer buffer)
768           (hi::with-mark ((mark (hi::buffer-point buffer) :left-inserting))
769             (let* ((string-len (send nsstring 'length))
770                    (line-start 0)
771                    (first-line-terminator ())
772                    (first-line (hi::mark-line mark))
773                    (previous first-line)
774                    (buffer (hi::line-%buffer first-line)))
775               (slet ((remaining-range (ns-make-range 0 1)))
776                 (rlet ((line-end-index :unsigned)
777                        (contents-end-index :unsigned))
778                   (do* ((number (+ (hi::line-number first-line) hi::line-increment)
779                                 (+ number hi::line-increment)))
780                        ((= line-start string-len)
781                         (let* ((line (hi::mark-line mark)))
782                           (hi::insert-string mark (make-string 0))
783                           (setf (hi::line-next previous) line
784                                 (hi::line-previous line) previous))
785                         nil)
786                     (setf (pref remaining-range :<NSR>ange.location) line-start)
787                     (send nsstring
788                           :get-line-start (%null-ptr)
789                           :end line-end-index
790                           :contents-end contents-end-index
791                           :for-range remaining-range)
792                     (let* ((contents-end (pref contents-end-index :unsigned))
793                            (line-end (pref line-end-index :unsigned))
794                            (chars (make-string (- contents-end line-start))))
795                       (do* ((i line-start (1+ i))
796                             (j 0 (1+ j)))
797                            ((= i contents-end))
798                         (setf (schar chars j) (code-char (send nsstring :character-at-index i))))
799                       (unless first-line-terminator
800                         (let* ((terminator (code-char
801                                             (send nsstring :character-at-index
802                                                   contents-end))))
803                           (setq first-line-terminator
804                                 (case terminator
805                                   (#\return (if (= line-end (+ contents-end 2))
806                                               :cp/m
807                                               :macos))
808                                   (t :unix)))))
809                       (if (eq previous first-line)
810                         (progn
811                           (hi::insert-string mark chars)
812                           (hi::insert-character mark #\newline)
813                           (setq first-line nil))
814                         (if (eq string-len contents-end)
815                           (hi::insert-string mark chars)
816                           (let* ((line (hi::make-line
817                                         :previous previous
818                                         :%buffer buffer
819                                         :chars chars
820                                         :number number)))
821                             (setf (hi::line-next previous) line)
822                             (setq previous line))))
823                       (setq line-start line-end)))))
824               (when first-line-terminator
825                 (setf (hi::buffer-external-format buffer) first-line-terminator))))
826           (setf (hi::buffer-modified buffer) nil)
827           (hi::buffer-start (hi::buffer-point buffer))
828           buffer)
829      (setf (hi::buffer-document buffer) document))))
830
831(setq hi::*beep-function* #'(lambda (stream)
832                              (declare (ignore stream))
833                              (#_NSBeep)))
834
835
836;;; This function must run in the main event thread.
837(defun %hemlock-frame-for-textstorage (ts title activate)
838  (let* ((pane (textpane-for-textstorage ts))
839         (w (send pane 'window)))
840    (when title (send w :set-title (%make-nsstring title)))
841    (when activate (activate-window w))
842    w))
843
844(defun hemlock-frame-for-textstorage (ts title activate)
845  (process-interrupt *cocoa-event-process*
846                     #'%hemlock-frame-for-textstorage
847                     ts title activate))
848
849
850(defun for-each-textview-using-storage (textstorage f)
851  (let* ((layouts (send textstorage 'layout-managers)))
852    (unless (%null-ptr-p layouts)
853      (dotimes (i (send layouts 'count))
854        (let* ((layout (send layouts :object-at-index i))
855               (containers (send layout 'text-containers)))
856          (unless (%null-ptr-p containers)
857            (dotimes (j (send containers 'count))
858              (let* ((container (send containers :object-at-index j))
859                     (tv (send container 'text-view)))
860                (funcall f tv)))))))))
861
862
863 
864(defun hi::document-begin-editing (document)
865  (send (slot-value document 'textstorage) 'begin-editing))
866
867(defun hi::document-end-editing (document)
868  (let* ((textstorage (slot-value document 'textstorage)))
869    (send textstorage 'end-editing)
870    (for-each-textview-using-storage
871     textstorage
872     #'(lambda (tv)
873         (send tv :scroll-range-to-visible (send tv 'selected-range))))))
874
875(defun hi::document-set-point-position (document)
876  (let* ((textstorage (slot-value document 'textstorage))
877         (string (send textstorage 'string))
878         (buffer (buffer-cache-buffer (hemlock-buffer-string-cache string)))
879         (point (hi::buffer-point buffer))
880         (pos (mark-absolute-position point)))
881    (for-each-textview-using-storage
882     textstorage
883     #'(lambda (tv)
884         (slet ((selection (ns-make-range pos 0)))
885          (send tv :set-selected-range selection))))))
886
887
888(defun textstorage-note-insertion-at-position (textstorage pos n)
889  (send textstorage
890        :edited #$NSTextStorageEditedAttributes
891        :range (ns-make-range pos 0)
892        :change-in-length n)
893  (send textstorage
894        :edited #$NSTextStorageEditedCharacters
895        :range (ns-make-range pos n)
896        :change-in-length 0))
897
898(defun hi::buffer-note-insertion (buffer mark n)
899  (when (hi::bufferp buffer)
900    (let* ((document (hi::buffer-document buffer))
901           (textstorage (if document (slot-value document 'textstorage))))
902      (when textstorage
903        (let* ((pos (mark-absolute-position mark)))
904          (unless (eq (hi::mark-%kind mark) :right-inserting)
905            (decf pos n))
906          #+debug
907          (format t "~&pos = ~d, n = ~d" pos n)
908          (let* ((display (hemlock-buffer-string-cache (send textstorage 'string))))
909            (reset-buffer-cache display) 
910            (update-line-cache-for-index display pos))
911          (textstorage-note-insertion-at-position textstorage pos n))))))
912
913 
914
915(defun hi::buffer-note-deletion (buffer mark n)
916  (when (hi::bufferp buffer)
917    (let* ((document (hi::buffer-document buffer))
918           (textstorage (if document (slot-value document 'textstorage))))
919      (when textstorage
920        (let* ((pos (mark-absolute-position mark)))
921          (setq n (abs n))
922          #+debug
923          (format t "~& pos = ~d, n = ~d" pos n)
924          (force-output)
925          (send textstorage
926                :edited #$NSTextStorageEditedAttributes
927                :range (ns-make-range pos n)
928                :change-in-length (- n))
929          (let* ((cache (hemlock-buffer-string-cache (send textstorage 'string))))
930            (reset-buffer-cache cache) 
931            (update-line-cache-for-index cache pos)))))))
932
933(defun hi::set-document-modified (document flag)
934  (send document
935        :update-change-count (if flag #$NSChangeDone #$NSChangeCleared)))
936
937
938(defun hi::document-panes (document)
939  (let* ((ts (slot-value document 'textstorage))
940         (panes ()))
941    (for-each-textview-using-storage
942     ts
943     #'(lambda (tv)
944         (let* ((pane (text-view-pane tv)))
945           (unless (%null-ptr-p pane)
946             (push pane panes)))))
947    panes))
948
949   
950
951(defun size-of-char-in-font (f)
952  (let* ((sf (send f 'screen-font)))
953    (if (%null-ptr-p sf) (setq sf f))
954    (values (send sf 'default-line-height-for-font)
955            (send sf :width-of-string #@" "))))
956         
957   
958(defun get-size-for-textview (font nrows ncols)
959  (multiple-value-bind (h w) (size-of-char-in-font font)
960    (values (fceiling (* nrows h))
961            (fceiling (* ncols w)))))
962
963
964(defun size-textview-containers (tv char-height char-width nrows ncols)
965  (let* ((height (fceiling (* nrows char-height)))
966         (width (fceiling (* ncols char-width)))
967         (scrollview (send (send tv 'superview) 'superview))
968         (window (send scrollview 'window)))
969    (rlet ((tv-size :<NSS>ize :height height
970                    :width (+ width (* 2 (send (send tv 'text-container)
971                      'line-fragment-padding)))))
972      (when (send scrollview 'has-vertical-scroller)
973        (send scrollview :set-vertical-line-scroll char-height)
974        (send scrollview :set-vertical-page-scroll char-height))
975      (slet ((sv-size
976              (send (@class ns-scroll-view)
977                    :frame-size-for-content-size tv-size
978                    :has-horizontal-scroller
979                    (send scrollview 'has-horizontal-scroller)
980                    :has-vertical-scroller
981                    (send scrollview 'has-vertical-scroller)
982                    :border-type (send scrollview 'border-type))))
983        (slet ((sv-frame (send scrollview 'frame)))
984          (incf (pref sv-size :<NSS>ize.height)
985                (pref sv-frame :<NSR>ect.origin.y))
986          (send window :set-content-size sv-size)
987          (send window :set-resize-increments
988                (ns-make-size char-width char-height)))))))
989                                   
990 
991(defclass lisp-editor-window-controller (ns:ns-window-controller)
992    ()
993  (:metaclass ns:+ns-object))
994
995   
996;;; The LispEditorWindowController is the textview's "delegate": it
997;;; gets consulted before certain actions are performed, and can
998;;; perform actions on behalf of the textview.
999
1000
1001
1002;;; The LispEditorDocument class.
1003
1004
1005(defclass lisp-editor-document (ns:ns-document)
1006    ((textstorage :foreign-type :id))
1007  (:metaclass ns:+ns-object))
1008
1009(define-objc-method ((:id init) lisp-editor-document)
1010  (let* ((doc (send-super 'init)))
1011    (unless (%null-ptr-p doc)
1012      (let* ((buffer (make-hemlock-buffer
1013                      (lisp-string-from-nsstring (send doc 'display-name))
1014                      :modes '("Lisp"))))
1015        (setf (slot-value doc 'textstorage)
1016              (make-textstorage-for-hemlock-buffer buffer)
1017              (hi::buffer-document buffer) doc)))
1018    doc))
1019                     
1020
1021(define-objc-method ((:id :read-from-file filename
1022                          :of-type type)
1023                     lisp-editor-document)
1024  (declare (ignorable type))
1025  (let* ((pathname (lisp-string-from-nsstring filename))
1026         (buffer-name (hi::pathname-to-buffer-name pathname))
1027         (buffer (or
1028                  (hemlock-document-buffer self)
1029                  (let* ((b (make-hemlock-buffer buffer-name)))
1030                    (setf (hi::buffer-pathname b) pathname)
1031                    (setf (slot-value self 'textstorage)
1032                          (make-textstorage-for-hemlock-buffer b))
1033                    b)))
1034         (data (make-objc-instance 'ns:ns-data
1035                                   :with-contents-of-file filename))
1036         (string (make-objc-instance 'ns:ns-string
1037                                     :with-data data
1038                                     :encoding #$NSASCIIStringEncoding)))
1039    (hi::document-begin-editing self)
1040    (nsstring-to-buffer string buffer)
1041    (let* ((textstorage (slot-value self 'textstorage))
1042           (display (hemlock-buffer-string-cache (send textstorage 'string))))
1043      (reset-buffer-cache display) 
1044      (update-line-cache-for-index display 0)
1045      (textstorage-note-insertion-at-position
1046       textstorage
1047       0
1048       (hemlock-buffer-length buffer)))
1049    (hi::document-end-editing self)
1050    (setf (hi::buffer-modified buffer) nil)
1051    (hi::process-file-options buffer pathname)
1052    self))
1053   
1054 
1055(defmethod hemlock-document-buffer (document)
1056  (let* ((string (send (slot-value document 'textstorage) 'string)))
1057    (unless (%null-ptr-p string)
1058      (let* ((cache (hemlock-buffer-string-cache string)))
1059        (when cache (buffer-cache-buffer cache))))))
1060
1061(define-objc-method ((:id :data-representation-of-type type)
1062                      lisp-editor-document)
1063  (declare (ignorable type))
1064  (let* ((buffer (hemlock-document-buffer self)))
1065    (when buffer
1066      (setf (hi::buffer-modified buffer) nil)))
1067  (send (send (slot-value self 'textstorage) 'string)
1068        :data-using-encoding #$NSASCIIStringEncoding
1069        :allow-lossy-conversion t))
1070
1071
1072;;; Shadow the setFileName: method, so that we can keep the buffer
1073;;; name and pathname in synch with the document.
1074(define-objc-method ((:void :set-file-name full-path)
1075                     lisp-editor-document)
1076  (send-super :set-file-name full-path)
1077  (let* ((buffer (hemlock-document-buffer self)))
1078    (when buffer
1079      (let* ((new-pathname (lisp-string-from-nsstring full-path)))
1080        (setf (hi::buffer-name buffer) (hi::pathname-to-buffer-name new-pathname))
1081        (setf (hi::buffer-pathname buffer) new-pathname)))))
1082 
1083(define-objc-method ((:void make-window-controllers) lisp-editor-document)
1084  (let* ((controller (make-objc-instance
1085                      'lisp-editor-window-controller
1086                      :with-window (%hemlock-frame-for-textstorage
1087                                    (slot-value self 'textstorage) nil nil))))
1088    (send self :add-window-controller controller)
1089    (send controller 'release)))         
1090
1091#|
1092(define-objc-method ((:void :window-controller-did-load-nib acontroller)
1093                     lisp-editor-document)
1094  (send-super :window-controller-did-load-nib  acontroller)
1095  ;; Apple/NeXT thinks that adding extra whitespace around cut & pasted
1096  ;; text is "smart".  Really, really smart insertion and deletion
1097  ;; would alphabetize the selection for you (byChars: or byWords:);
1098  ;; sadly, if you want that behavior you'll have to do it yourself.
1099  ;; Likewise with the extra spaces.
1100  (with-slots (text-view echoarea packagename filedata) self
1101    (send text-view :set-alignment  #$NSNaturalTextAlignment)
1102    (send text-view :set-smart-insert-delete-enabled nil)
1103    (send text-view :set-rich-text nil)
1104    (send text-view :set-uses-font-panel t)
1105    (send text-view :set-uses-ruler nil)
1106    (with-lock-grabbed (*open-editor-documents-lock*)
1107      (push (make-cocoa-editor-info
1108             :document (%setf-macptr (%null-ptr) self)
1109             :controller (%setf-macptr (%null-ptr) acontroller)
1110             :listener nil)
1111            *open-editor-documents*))
1112    (setf (slot-value acontroller 'textview) text-view
1113          (slot-value acontroller 'echoarea) echoarea
1114          (slot-value acontroller 'packagename) packagename)
1115    (send text-view :set-delegate acontroller)
1116    (let* ((font (default-font)))
1117      (multiple-value-bind (height width)
1118          (size-of-char-in-font font)
1119        (size-textview-containers text-view height width 24 80))
1120      (send text-view
1121            :set-typing-attributes
1122            (create-text-attributes
1123             :font font
1124             :color (send (@class ns-color) 'black-color)))
1125      (unless (%null-ptr-p filedata)
1126        (send text-view
1127              :replace-characters-in-range (ns-make-range 0 0)
1128              :with-string (make-objc-instance
1129                            'ns-string
1130                            :with-data filedata
1131                            :encoding #$NSASCIIStringEncoding))
1132))))
1133|#
1134
1135(define-objc-method ((:void close) lisp-editor-document)
1136  (let* ((textstorage (slot-value self 'textstorage)))
1137    (setf (slot-value self 'textstorage) (%null-ptr))
1138    (unless (%null-ptr-p textstorage)
1139      (close-hemlock-textstorage textstorage)))
1140    (send-super 'close))
1141
1142
1143(provide "COCOA-EDITOR")
Note: See TracBrowser for help on using the repository browser.