source: trunk/ccl/examples/hemlock-textstorage.lisp @ 556

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

Lots of changes. Still needs event-translation work (and lots of other things.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 17.6 KB
Line 
1(in-package "CCL")
2
3(require "COCOA")
4
5(eval-when (:compile-toplevel :execute)
6  (use-interface-dir :cocoa))
7
8
9(defstruct hemlock-display
10  buffer                                ; the hemlock buffer
11  buflen                                ; length of buffer, if known
12  workline                              ; cache for character-at-index
13  workline-offset                       ; cached offset of workline
14  workline-length                       ; length of cached workline
15  )
16
17(defun reset-display-cache (d &optional (buffer (hemlock-display-buffer d)
18                                                buffer-p))
19  (when buffer-p (setf (hemlock-display-buffer d) buffer))
20  (let* ((workline (hemlock::mark-line
21                    (hemlock::buffer-start-mark buffer))))
22    (setf (hemlock-display-buflen d) (hemlock-buffer-length buffer)
23          (hemlock-display-workline-offset d) 0
24          (hemlock-display-workline d) workline
25          (hemlock-display-workline-length d) (hemlock::line-length workline))
26    d))
27         
28
29(defun hemlock-buffer-length (buffer)
30  (hemlock::count-characters (hemlock::buffer-region buffer)))
31
32(defclass hemlock-buffer-string (ns:ns-string)
33    ((display :initform nil :initarg :display :accessor hemlock-buffer-string-display))
34  (:metaclass ns:+ns-object))
35
36
37(defun update-line-cache-for-index (d index)
38  (let* ((line (or
39                (hemlock-display-workline d)
40                (progn
41                  (reset-display-cache d)
42                  (hemlock-display-workline d))))
43         (pos (hemlock-display-workline-offset d))
44         (len (hemlock-display-workline-length d))
45         (moved nil))
46    (loop
47      (when (and (>= index pos)
48                   (< index (1+ (+ pos len))))
49          (let* ((idx (- index pos)))
50            (when moved
51              (setf (hemlock-display-workline d) line
52                    (hemlock-display-workline-offset d) pos
53                    (hemlock-display-workline-length d) len))
54            (return (values line idx))))
55        (setq moved t)
56      (if (< index pos)
57        (setq line (hemlock::line-previous line)
58              len (hemlock::line-length line)
59              pos (1- (- pos len)))
60        (setq line (hemlock::line-next line)
61              pos (1+ (+ pos len))
62              len (hemlock::line-length line))))))
63 
64(defun hemlock-char-at-index (d index)
65  (multiple-value-bind (line idx) (update-line-cache-for-index d index)
66    (let* ((len (hemlock::line-length line)))
67      (if (< idx len)
68        (hemlock::line-character line idx)
69        #\newline))))
70
71(defun move-hemlock-mark-to-absolute-position (mark d index)
72  (multiple-value-bind (line idx) (update-line-cache-for-index d index)
73    (hemlock::move-to-position mark idx line)))
74
75(defun mark-absolute-position (mark)
76  (let* ((pos (hemlock::mark-charpos mark)))
77    (do* ((line (hemlock::line-previous (hemlock::mark-line mark))
78                (hemlock::line-previous line)))
79         ((null line) pos)
80      (incf pos (1+ (hemlock::line-length line))))))
81
82
83
84(define-objc-method ((:unichar :character-at-index (unsigned index))
85                     hemlock-buffer-string)
86  ;(#_NSLog #@"Character at index %d" :unsigned index )
87  (char-code (hemlock-char-at-index (hemlock-buffer-string-display self) index)))
88
89
90(define-objc-method ((:unsigned length)
91                     hemlock-buffer-string)
92  (let* ((display-object (hemlock-buffer-string-display self)))
93      (or (hemlock-display-buflen display-object)
94          (setf (hemlock-display-buflen display-object)
95                (hemlock-buffer-length (hemlock-display-buffer display-object))))))
96
97
98
99(define-objc-method ((:id description)
100                     hemlock-buffer-string)
101  (let* ((d (hemlock-buffer-string-display self))
102         (b (hemlock-display-buffer d)))
103    (with-cstrs ((s (format nil "~a" b)))
104      (send (@class ns-string) :string-with-format #@"<%s for %s>"
105        (:address (#_object_getClassName self) :address s)))))
106
107                     
108(defclass lisp-text-storage (ns:ns-text-storage)
109    ((string :foreign-type :id)
110     (defaultattrs :foreign-type :id))
111  (:metaclass ns:+ns-object))
112
113(define-objc-method ((:id :init-with-string s) lisp-text-storage)
114  (let* ((newself (send-super 'init)))
115    (setf (slot-value newself 'string) s
116          (slot-value newself 'defaultattrs) (create-text-attributes))
117    newself))
118         
119(define-objc-method ((:id string) lisp-text-storage)
120  (slot-value self 'string))
121
122(define-objc-method ((:id :attributes-at-index (:unsigned index)
123                          :effective-range ((* :<NSR>ange) rangeptr))
124                     lisp-text-storage)
125  '(#_NSLog #@"Attributes at index %d, rangeptr = %x"
126           :unsigned index :address rangeptr)
127  (let* ((hemlock-display (hemlock-buffer-string-display (slot-value self 'string)))
128         (len (hemlock-display-buflen hemlock-display)))
129    (if (>= index len)
130      (error "This should be an NSRangeError"))
131    (unless (%null-ptr-p rangeptr)
132      (setf (pref rangeptr :<NSR>ange.location) 0
133            (pref rangeptr :<NSR>ange.length) len))
134    (slot-value self 'defaultattrs)))
135
136(define-objc-method ((:void :replace-characters-in-range (:<NSR>ange r)
137                            :with-string string)
138                     lisp-text-storage)
139  (#_NSLog #@"replace-characters-in-range (%d %d) with-string %@"
140           :unsigned (pref r :<NSR>ange.location)
141           :unsigned (pref r :<NSR>ange.length)
142           :id string))
143
144(define-objc-method ((:void :replace-characters-in-range  (:<NSR>ange r)
145                            :with-attributed-string string)
146                     lisp-text-storage)
147  (#_NSLog #@"replace-characters-in-range (%d %d) with-attributed-string %@"
148           :unsigned (pref r :<NSR>ange.location)
149           :unsigned (pref r :<NSR>ange.length)
150           :id string))
151
152(define-objc-method ((:void :set-attributes attributes
153                            :range (:<NSR>ange r))
154                     lisp-text-storage)
155  (#_NSLog #@"set-attributes %@ range (%d %d)"
156           :id attributes
157           :unsigned (pref r :<NSR>ange.location)
158           :unsigned (pref r :<NSR>ange.length)))
159
160
161(define-objc-method ((:id description)
162                     lisp-text-storage)
163  (send (@class ns-string) :string-with-format #@"%s : string %@"
164        (:address (#_object_getClassName self) :id (slot-value self 'string))))
165
166
167(defclass lisp-text-view (ns:ns-text-view)
168    ((timer :foreign-type :id :accessor blink-timer)
169     (blink-pos :foreign-type :int :accessor blink-pos)
170     (blink-phase :foreign-type :<BOOL> :accessor blink-phase)
171     (blink-char :foreign-type :int :accessor blink-char))
172  (:metaclass ns:+ns-object))
173
174(defmethod text-view-buffer ((self lisp-text-view))
175  (hemlock-display-buffer (hemlock-buffer-string-display (send (send self 'text-storage) 'string))))
176
177;;; HEMLOCK-EXT::DEFINE-CLX-MODIFIER is kind of misnamed; we can use
178;;; it to map NSEvent modifier keys to key-event modifiers.
179(hemlock-ext::define-clx-modifier #$NSShiftKeyMask "Shift")
180(hemlock-ext::define-clx-modifier #$NSControlKeyMask "Control")
181(hemlock-ext::define-clx-modifier #$NSAlternateKeyMask "Meta")
182(hemlock-ext::define-clx-modifier #$NSAlphaShiftKeyMask "Lock")
183
184(defun nsevent-to-key-event (nsevent)
185  (let* ((unmodchars (send nsevent 'characters-ignoring-modifiers))
186         (n (if (%null-ptr-p unmodchars)
187              0
188              (send unmodchars 'length)))
189         (c (if (eql n 1)
190              (send unmodchars :character-at-index 0))))
191    (when c
192      (let* ((bits 0)
193             (modifiers (send nsevent 'modifier-flags)))
194        (dolist (map hemlock-ext::*modifier-translations*)
195          (when (logtest modifiers (car map))
196            (setq bits (logior bits (hemlock-ext::key-event-modifier-mask
197                                     (cdr map))))))
198        (hemlock-ext::make-key-event c bits)))))
199   
200 
201(define-objc-method ((:void :key-down event)
202                     lisp-text-view)
203  (#_NSLog #@"Key down event = %@" :address event)
204  (format t "~& keycode = ~s~&" (send event 'key-code))
205  (let* ((buffer (text-view-buffer self)))
206    (when buffer
207      (let* ((info (hemlock-frame-command-info (send self 'window))))
208        (when info
209          (let* ((key-event (nsevent-to-key-event event)))
210            (when event
211              (unless (eq buffer hi::*current-buffer*)
212                (setf (hi::current-buffer) buffer))
213              (hi::interpret-key-event key-event info))))))))
214
215(define-objc-method ((:void :set-selected-range (:<NSR>ange r)
216                            :affinity (:<NSS>election<A>ffinity affinity)
217                            :still-selecting (:<BOOL> still-selecting))
218                     lisp-text-view)
219  (let* ((d (hemlock-buffer-string-display (send self 'string)))
220         (point (hemlock::buffer-point (hemlock-display-buffer d)))
221         (location (pref r :<NSR>ange.location))
222         (len (pref r :<NSR>ange.length)))
223    (when (eql len 0)
224      (move-hemlock-mark-to-absolute-position point d location))
225    (send-super :set-selected-range r
226                :affinity affinity
227                :still-selecting still-selecting)))
228 
229
230(defun make-textstorage-for-hemlock-buffer (buffer)
231  (setf (hi::buffer-text-storage buffer)
232        (make-objc-instance 'lisp-text-storage
233                            :with-string
234                            (make-instance
235                             'hemlock-buffer-string
236                             :display
237                             (reset-display-cache
238                              (make-hemlock-display)
239                              buffer)))))
240
241(defun make-scrolling-text-view-for-buffer (buffer x y width height hscroll-p)
242  (slet ((contentrect (ns-make-rect x y width height)))
243    (let* ((textstorage (make-textstorage-for-hemlock-buffer buffer))
244           (scrollview (send (make-objc-instance
245                              'ns-scroll-view
246                              :with-frame contentrect) 'autorelease)))
247      (send scrollview :set-border-type #$NSBezelBorder)
248      (send scrollview :set-has-vertical-scroller t)
249      (send scrollview :set-has-horizontal-scroller hscroll-p)
250      (send scrollview :set-rulers-visible nil)
251      (send scrollview :set-autoresizing-mask (logior
252                                               #$NSViewWidthSizable
253                                               #$NSViewHeightSizable))
254      (send (send scrollview 'content-view) :set-autoresizes-subviews t)
255      (let* ((layout (make-objc-instance 'ns-layout-manager)))
256        (send textstorage :add-layout-manager layout)
257        (send layout 'release)
258        (slet* ((contentsize (send scrollview 'content-size))
259                (containersize (ns-make-size
260                                1.0f7
261                                1.0f7))
262                (tv-frame (ns-make-rect
263                           0.0f0
264                           0.0f0
265                           (pref contentsize :<NSS>ize.width)
266                           (pref contentsize :<NSS>ize.height))))
267          (let* ((container (send (make-objc-instance
268                                   'ns-text-container
269                                   :with-container-size containersize)
270                                  'autorelease)))
271            (send layout :add-text-container container)
272            (let* ((tv (send (make-objc-instance 'lisp-text-view
273                                                 :with-frame tv-frame
274                                                 :text-container container)
275                             'autorelease)))
276              (send tv :set-min-size (ns-make-size
277                                      0.0f0
278                                      (pref contentsize :<NSS>ize.height)))
279              (send tv :set-max-size (ns-make-size 1.0f7 1.0f7))
280              (send tv :set-rich-text nil)
281              (send tv :set-horizontally-resizable hscroll-p)
282              (send tv :set-vertically-resizable t) 
283              (send tv :set-autoresizing-mask #$NSViewWidthSizable)
284              (send container :set-width-tracks-text-view (not hscroll-p))
285              (send container :set-height-tracks-text-view nil)
286              (send scrollview :set-document-view tv)         
287              (values tv scrollview))))))))
288
289
290(defun make-scrolling-textview-for-view (superview buffer hscroll-p)
291  (slet ((contentrect (send (send superview 'content-view) 'frame)))
292    (multiple-value-bind (tv scrollview)
293        (make-scrolling-text-view-for-buffer
294         buffer
295         (pref contentrect :<NSR>ect.origin.x)
296         (pref contentrect :<NSR>ect.origin.y)
297         (pref contentrect :<NSR>ect.size.width)
298         (pref contentrect :<NSR>ect.size.height)
299         hscroll-p)
300      (send superview :set-content-view scrollview)
301      tv)))
302
303(defun make-scrolling-textview-for-window (&key window buffer hscroll-p)
304  (make-scrolling-textview-for-view (send window 'content-view) buffer hscroll-p))
305
306(defmethod hemlock-frame-command-info ((w ns:ns-window))
307  nil)
308
309(defclass hemlock-frame (ns:ns-window)
310    ((command-info :initform (hi::make-command-interpreter-info)
311                   :accessor hemlock-frame-command-info))
312  (:metaclass ns:+ns-object))
313
314(defmethod shared-initialize :after ((w hemlock-frame)
315                                     slot-names
316                                     &key &allow-other-keys)
317  (declare (ignore slot-names))
318  (let ((info (hemlock-frame-command-info w)))
319    (when info
320      (setf (hi::command-interpreter-info-frame info) w))))
321
322(defun get-cocoa-window-flag (w flagname)
323  (case flagname
324    (:accepts-mouse-moved-events
325     (send w 'accepts-mouse-moved-events))
326    (:cursor-rects-enabled
327     (send w 'are-cursor-rects-enabled))
328    (:auto-display
329     (send w 'is-autodisplay))))
330
331(defun (setf get-cocoa-window-flag) (value w flagname)
332  (case flagname
333    (:accepts-mouse-moved-events
334     (send w :set-accepts-mouse-moved-events value))
335    (:auto-display
336     (send w :set-autodisplay value))))
337
338(defun activate-window (w)
339  ;; Make w the "key" and frontmost window.  Make it visible, if need be.
340  (send w :make-key-and-order-front nil))
341
342(defun new-hemlock-document-window (title &key
343                                          (x 0.0)
344                                          (y 0.0)
345                                          (height 200.0)
346                                          (width 500.0)
347                                          (closable t)
348                                          (iconifyable t)
349                                          (metal t)
350                                          (expandable t)
351                                          (backing :buffered)
352                                          (defer nil)
353                                          (accepts-mouse-moved-events nil)
354                                          (auto-display t)
355                                          (activate t))
356  (rlet ((frame :<NSR>ect :origin.x (float x) :origin.y (float y) :size.width (float width) :size.height (float height)))
357    (let* ((stylemask
358            (logior #$NSTitledWindowMask
359                    (if closable #$NSClosableWindowMask 0)
360                    (if iconifyable #$NSMiniaturizableWindowMask 0)
361                    (if expandable #$NSResizableWindowMask 0)
362                    (if metal #$NSTexturedBackgroundWindowMask 0)))
363           (backing-type
364            (ecase backing
365              ((t :retained) #$NSBackingStoreRetained)
366              ((nil :nonretained) #$NSBackingStoreNonretained)
367              (:buffered #$NSBackingStoreBuffered)))
368           (w (make-instance
369               'hemlock-frame
370               :with-content-rect frame
371               :style-mask stylemask
372               :backing backing-type
373               :defer defer)))
374      (send w :set-title (%make-nsstring title))
375      (setf (get-cocoa-window-flag w :accepts-mouse-moved-events)
376            accepts-mouse-moved-events
377            (get-cocoa-window-flag w :auto-display)
378            auto-display)
379      (when activate (activate-window w))
380      (values w (add-box-to-window w :reserve-below 20.0)))))
381
382(defun add-box-to-window (w &key (reserve-above 0.0f0) (reserve-below 0.0f0))
383  (let* ((window-content-view (send w 'content-view)))
384    (slet ((window-frame (send window-content-view 'frame)))
385      (slet ((box-rect (ns-make-rect 0.0f0
386                                      reserve-below
387                                      (pref window-frame :<NSR>ect.size.width)
388                                      (- (pref window-frame :<NSR>ect.size.height) (+ reserve-above reserve-below)))))
389        (let* ((box (make-objc-instance 'ns-box :with-frame box-rect)))
390          (send box :set-autoresizing-mask (logior
391                                            #$NSViewWidthSizable
392                                            #$NSViewHeightSizable))
393          (send box :set-box-type #$NSBoxSecondary)
394          (send box :set-border-type #$NSLineBorder)
395          (send box :set-title-position #$NSBelowBottom)
396          (send window-content-view :add-subview box)
397          box)))))
398         
399                                       
400                                     
401(defun textview-for-hemlock-buffer (b &key (horizontal-scroll-p t))
402  (process-interrupt
403   *cocoa-event-process*
404   #'(lambda ()
405      (let* ((name (hi::buffer-name b)))
406        (multiple-value-bind (window box)
407            (new-hemlock-document-window name :activate nil)
408          (let* ((tv (make-scrolling-textview-for-view box
409                                                       b
410                                                       horizontal-scroll-p)))
411            (multiple-value-bind (height width)
412                (size-of-char-in-font (default-font))
413              (size-textview-containers tv height width 24 80))
414            (activate-window window)
415            tv))))))
416
417
418(defun read-file-to-hemlock-buffer (path)
419  (hemlock::find-file-buffer path))
420
421(defun hemlock-buffer-from-nsstring (nsstring name)
422  (let* ((buffer (hi::make-buffer name)))
423    (hi::delete-region (hi::buffer-region buffer))
424    (hi::modifying-buffer buffer)
425    (hi::with-mark ((mark (hi::buffer-point buffer) :left-inserting))
426      (let* ((string-len (send nsstring 'length))
427             (line-start 0)
428             (first-line (hi::mark-line mark))
429             (previous first-line)
430             (buffer (hi::line-%buffer first-line)))
431        (slet ((remaining-range (ns-make-range 0 1)))
432          (rlet ((line-end-index :unsigned)
433                 (contents-end-index :unsigned))
434            (do* ((number (+ (hi::line-number first-line) hi::line-increment)
435                          (+ number hi::line-increment)))
436                 ((= line-start string-len))
437              (setf (pref remaining-range :<NSR>ange.location) line-start)
438              (send nsstring
439                    :get-line-start (%null-ptr)
440                    :end line-end-index
441                    :contents-end contents-end-index
442                    :for-range remaining-range)
443              (let* ((contents-end (pref contents-end-index :unsigned))
444                     (chars (make-string (- contents-end line-start))))
445                (do* ((i line-start (1+ i))
446                      (j 0 (1+ j)))
447                     ((= i contents-end))
448                  (setf (schar chars j) (code-char (send nsstring :character-at-index i))))
449                (if (eq previous first-line)
450                  (progn
451                    (hi::insert-string mark chars)
452                    (hi::insert-character mark #\newline)
453                    (setq first-line nil))
454                  (if (eq (pref line-end-index :unsigned) string-len)
455                    (hi::insert-string mark chars)
456                    (let* ((line (hi::make-line
457                                  :previous previous
458                                  :%buffer buffer
459                                  :chars chars
460                                  :number number)))
461                      (setf (hi::line-next previous) line)
462                      (setq previous line))))
463                (setq line-start (pref line-end-index :unsigned))))))))
464    buffer))
465
466(setq hi::*beep-function* #'(lambda (stream)
467                              (declare (ignore stream))
468                              (#_NSBeep)))
469
470(defun edit (path)
471  (textview-for-hemlock-buffer (read-file-to-hemlock-buffer path)))
472
473(defun for-each-textview-using-storage (textstorage f)
474  (let* ((layouts (send textstorage 'layout-managers)))
475    (unless (%null-ptr-p layouts)
476      (dotimes (i (send layouts 'count))
477        (let* ((layout (send layouts :object-at-index i))
478               (containers (send layout 'text-containers)))
479          (unless (%null-ptr-p containers)
480            (dotimes (j (send containers 'count))
481              (let* ((container (send containers :object-at-index j))
482                     (tv (send container 'text-view)))
483                (funcall f tv)))))))))
484 
485
486(defun hi::textstorage-set-point-position (textstorage)
487  (format t "~& setting point ...")
488  (let* ((string (send textstorage 'string))
489         (buffer (hemlock-display-buffer (hemlock-buffer-string-display string)))
490         (point (hi::buffer-point buffer))
491         (pos (mark-absolute-position point)))
492    (for-each-textview-using-storage
493     textstorage
494     #'(lambda (tv)
495         (send tv :set-selected-range (ns-make-range pos 0))))))
496
497             
498         
Note: See TracBrowser for help on using the repository browser.