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

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

Used DEFCLASS to creat classes, SLOT-VALUE or an accessor to access slots.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 13.2 KB
Line 
1(in-package "CCL")
2
3(require "COCOA")
4
5(eval-when (:compile-toplevel :execute)
6  (use-interface-dir :cocoa))
7
8(defvar *buffer-id-map* (make-id-map))
9
10(defstruct hemlock-display
11  buffer                                ; the hemlock buffer
12  buflen                                ; length of buffer, if known
13  workline                              ; cache for character-at-index
14  workline-offset                       ; cached offset of workline
15  workline-length                       ; length of cached workline
16  )
17
18(defun reset-display-cache (d &optional (buffer (hemlock-display-buffer d)
19                                                buffer-p))
20  (when buffer-p (setf (hemlock-display-buffer d) buffer))
21  (let* ((workline (hemlock::mark-line
22                    (hemlock::buffer-start-mark buffer))))
23    (setf (hemlock-display-buflen d) (hemlock-buffer-length buffer)
24          (hemlock-display-workline-offset d) 0
25          (hemlock-display-workline d) workline
26          (hemlock-display-workline-length d) (hemlock::line-length workline))
27    d))
28         
29
30(defun hemlock-buffer-length (buffer)
31  (hemlock::count-characters (hemlock::buffer-region buffer)))
32
33(defclass hemlock-buffer-string (ns:ns-string)
34    ((id :foreign-type :unsigned))
35  (:metaclass ns:+ns-object))
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
88              (id-map-object *buffer-id-map* (slot-value self 'id)) index)))
89
90
91(define-objc-method ((:unsigned length)
92                     hemlock-buffer-string)
93  (let* ((display-object (id-map-object *buffer-id-map* (slot-value self 'id))))
94      (or (hemlock-display-buflen display-object)
95          (setf (hemlock-display-buflen display-object)
96                (hemlock-buffer-length (hemlock-display-buffer display-object))))))
97
98
99(define-objc-method ((:unsigned lisp-id)
100                     hemlock-buffer-string)
101  (slot-value self 'id))
102
103(define-objc-method ((:id description)
104                     hemlock-buffer-string)
105  (send (@class ns-string) :string-with-format #@"%s : stringid %d/len %d"
106        (:address (#_object_getClassName self)
107                  :unsigned (slot-value self 'id)
108                  :unsigned (send self 'length))))
109
110(define-objc-method ((:id :init-with-buffer-id (:unsigned n))
111                     hemlock-buffer-string)
112  (send-super 'init)
113  (setf (slot-value self 'id) n)
114  self)
115
116
117
118                     
119(defclass lisp-text-storage (ns:ns-text-storage)
120    ((string :foreign-type :id)
121     (defaultattrs :foreign-type :id))
122  (:metaclass ns:+ns-object))
123
124
125(define-objc-method ((:id string) lisp-text-storage)
126  (slot-value self 'string))
127
128(define-objc-method ((:id :attributes-at-index (:unsigned index)
129                          :effective-range ((* :<NSR>ange) rangeptr))
130                     lisp-text-storage)
131  '(#_NSLog #@"Attributes at index %d, rangeptr = %x"
132           :unsigned index :address rangeptr)
133  (let* ((hemlock-display (id-map-object *buffer-id-map* (send (slot-value self 'string) 'lisp-id)))
134         (len (hemlock-display-buflen hemlock-display)))
135    (if (>= index len)
136      (error "This should be an NSRangeError"))
137    (unless (%null-ptr-p rangeptr)
138      (setf (pref rangeptr :<NSR>ange.location) 0
139            (pref rangeptr :<NSR>ange.length) len))
140    (slot-value self 'defaultattrs)))
141
142(define-objc-method ((:void :replace-characters-in-range (:<NSR>ange r)
143                            :with-string string)
144                     lisp-text-storage)
145  (#_NSLog #@"replace-characters-in-range (%d %d) with-string %@"
146           :unsigned (pref r :<NSR>ange.location)
147           :unsigned (pref r :<NSR>ange.length)
148           :id string))
149
150(define-objc-method ((:void :replace-characters-in-range  (:<NSR>ange r)
151                            :with-attributed-string string)
152                     lisp-text-storage)
153  (#_NSLog #@"replace-characters-in-range (%d %d) with-attributed-string %@"
154           :unsigned (pref r :<NSR>ange.location)
155           :unsigned (pref r :<NSR>ange.length)
156           :id string))
157
158(define-objc-method ((:void :set-attributes attributes
159                            :range (:<NSR>ange r))
160                     lisp-text-storage)
161  (#_NSLog #@"set-attributes %@ range (%d %d)"
162           :id attributes
163           :unsigned (pref r :<NSR>ange.location)
164           :unsigned (pref r :<NSR>ange.length)))
165
166(define-objc-method ((:id :init-with-buffer-id (:unsigned buffer-id-number))
167                     lisp-text-storage)
168  (send-super 'init)
169  (with-slots (string defaultattrs) self
170    (setq string (make-objc-instance
171                  'hemlock-buffer-string 
172                  :with-buffer-id buffer-id-number))
173    (setq defaultattrs (create-text-attributes)))
174  self)
175
176
177
178(define-objc-method ((:id description)
179                     lisp-text-storage)
180  (send (@class ns-string) :string-with-format #@"%s : string %@"
181        (:address (#_object_getClassName self)
182         :id (slot-value self 'string))))
183
184
185(defclass lisp-text-view (ns:ns-text-view)
186    ()
187  (:metaclass ns:+ns-object))
188
189(define-objc-method ((:void :key-down event)
190                     lisp-text-view)
191  (#_NSLog #@"Key down event : %@" :address event)
192  (send-super :key-down event))
193
194(define-objc-method ((:void :set-selected-range (:<NSR>ange r)
195                            :affinity (:<NSS>election<A>ffinity affinity)
196                            :still-selecting (:<BOOL> still-selecting))
197                     lisp-text-view)
198  (let* ((d (id-map-object *buffer-id-map*
199                           (send (send self 'string) 'lisp-id)))
200         (point (hemlock::buffer-point (hemlock-display-buffer d)))
201         (location (pref r :<NSR>ange.location))
202         (len (pref r :<NSR>ange.length)))
203    (when (eql len 0)
204      (move-hemlock-mark-to-absolute-position point d location))
205    (send-super :set-selected-range r
206                :affinity affinity
207                :still-selecting still-selecting)))
208 
209                           
210
211(define-objc-class-method ((:id :scrollview-with-rect (:<NSR>ect contentrect)
212                                :lisp-buffer-id (:unsigned stringid)
213                                :horizontal-scroll-p (:<BOOL> hscroll-p))
214                           lisp-text-view)
215    (let* ((textstorage (make-objc-instance
216                         'lisp-text-storage
217                         :with-buffer-id stringid))
218           (scrollview
219            (send (make-objc-instance
220                   'ns-scroll-view
221                   :with-frame contentrect)
222                  'autorelease)))
223      (send scrollview :set-border-type #$NSBezelBorder)
224      (send scrollview :set-has-vertical-scroller t)
225      (send scrollview :set-has-horizontal-scroller hscroll-p)
226      (send scrollview :set-rulers-visible nil)
227      (send scrollview :set-autoresizing-mask (logior #$NSViewWidthSizable
228                                                      #$NSViewHeightSizable))
229      (send (send scrollview 'content-view) :set-autoresizes-subviews t)
230      (let* ((layout (make-objc-instance 'ns-layout-manager)))
231        (send textstorage :add-layout-manager layout)
232        (send layout 'release)
233        (slet* ((contentsize (send scrollview 'content-size))
234                (containersize (ns-make-size
235                                    1.0f7
236                                    1.0f7))
237                (tv-frame (ns-make-rect
238                                      0.0f0
239                                      0.0f0
240                                      (pref contentsize :<NSS>ize.width)
241                                      (pref contentsize :<NSS>ize.height))))
242          (let* ((container (send (make-objc-instance
243                                   'ns-text-container
244                                   :with-container-size containersize)
245                                  'autorelease)))
246            (send layout :add-text-container container)
247            (let* ((tv (send
248                        (send (send self 'alloc)
249                              :init-with-frame tv-frame
250                              :text-container container)
251                        'autorelease)))
252              (send tv :set-min-size (ns-make-size
253                                      0.0f0
254                                      (pref contentsize :<NSS>ize.height)))
255              (send tv :set-max-size (ns-make-size 1.0f7 1.0f7))
256              (send tv :set-rich-text nil)
257              (send tv :set-horizontally-resizable hscroll-p)
258              (send tv :set-vertically-resizable t) 
259              (send tv :set-autoresizing-mask #$NSViewWidthSizable)
260              (send container :set-width-tracks-text-view (not hscroll-p))
261              (send container :set-height-tracks-text-view nil)
262              (send scrollview :set-document-view tv)         
263              tv))))))
264
265
266
267(define-objc-class-method ((:id :scrollview-for-window window
268                                :buffer-id (:unsigned buffer-id)
269                                :horizontal-scroll-p (:<BOOL> hscroll-p))
270                           lisp-text-view)
271    (let* ((contentview (send window 'content-view)))
272      (slet ((contentrect (send contentview 'frame)))
273        (let* ((tv  (send
274                            (@class lisp-text-view)
275                            :scrollview-with-rect contentrect
276                            :lisp-buffer-id buffer-id
277                            :horizontal-scroll-p hscroll-p))
278               (scrollview (send (send tv 'superview) 'superview)))
279          (send window :set-content-view scrollview)
280          tv))))
281   
282
283(defun get-cocoa-window-flag (w flagname)
284  (case flagname
285    (:accepts-mouse-moved-events
286     (send w 'accepts-mouse-moved-events))
287    (:cursor-rects-enabled
288     (send w 'are-cursor-rects-enabled))
289    (:auto-display
290     (send w 'is-autodisplay))))
291   
292(defun (setf get-cocoa-window-flag) (value w flagname)
293  (case flagname
294    (:accepts-mouse-moved-events
295     (send w :set-accepts-mouse-moved-events value))
296    (:auto-display
297     (send w :set-autodisplay value))))
298
299(defun activate-window (w)
300  ;; Make w the "key" and frontmost window.  Make it visible, if need be.
301  (send w :make-key-and-order-front nil))
302
303(defun new-cocoa-document-window (title &key
304                                        (class-name "NSWindow")
305                                        (x 0.0)
306                                        (y 0.0)
307                                        (height 200.0)
308                                        (width 500.0)
309                                        (closable t)
310                                        (iconifyable t)
311                                        (metal t)
312                                        (expandable t)
313                                        (backing :buffered)
314                                        (defer nil)
315                                        (accepts-mouse-moved-events nil)
316                                        (auto-display t)
317                                        (activate t))
318  (rlet ((frame :<NSR>ect :origin.x (float x) :origin.y (float y) :size.width (float width) :size.height (float height)))
319    (let* ((stylemask
320            (logior #$NSTitledWindowMask
321                    (if closable #$NSClosableWindowMask 0)
322                    (if iconifyable #$NSMiniaturizableWindowMask 0)
323                    (if expandable #$NSResizableWindowMask 0)
324                    (if metal #$NSTexturedBackgroundWindowMask 0)))
325           (backing-type
326            (ecase backing
327              ((t :retained) #$NSBackingStoreRetained)
328              ((nil :nonretained) #$NSBackingStoreNonretained)
329              (:buffered #$NSBackingStoreBuffered)))
330           (w (make-objc-instance
331               class-name
332               :with-content-rect frame
333               :style-mask stylemask
334               :backing backing-type
335               :defer defer)))
336      (send w :set-title (%make-nsstring title))
337      (setf (get-cocoa-window-flag w :accepts-mouse-moved-events)
338            accepts-mouse-moved-events
339            (get-cocoa-window-flag w :auto-display)
340            auto-display)
341      (when activate (activate-window w))
342      w)))
343                                           
344(defun textview-for-buffer (id &key (horizontal-scroll-p t))
345  (process-interrupt
346   *cocoa-event-process*
347   #'(lambda ()
348      (let* ((d (id-map-object *buffer-id-map* id))
349             (name (hi::buffer-name (hemlock-display-buffer d)))
350             (w (new-cocoa-document-window name :activate nil))
351             (tv 
352              (send (@class lisp-text-view)
353                    :scrollview-for-window w
354                    :buffer-id id
355                    :horizontal-scroll-p horizontal-scroll-p)))
356        (multiple-value-bind (height width)
357            (size-of-char-in-font (default-font))
358          (size-textview-containers tv height width 24 80))
359        (activate-window w)
360        tv))))
361
362(defun put-textview-in-box (box)
363  (slet ((r (send (send box 'content-view) 'bounds)))
364    (let* ((sv (make-objc-instance 'ns-scroll-view :with-frame r))
365           (sv-content-view (send sv 'content-view)))
366      (declare (ignorable sv-content-view))
367      (send box :set-content-view sv)
368      (slet ((sv-content-size (send sv 'content-size)))
369        (slet ((tv-frame (ns-make-rect 0.0f0 0.0f0
370                                       (pref sv-content-size :<NSS>ize.width)
371                                       (pref sv-content-size :<NSS>ize.height))))
372          (let* ((tv (make-objc-instance 'ns-text-view
373                                         :with-frame tv-frame)))
374            (send sv :set-document-view tv)
375            (send box :set-content-view sv)
376            (values tv sv)))))))
377
378(defun read-file-to-hemlock-buffer (path)
379  (let* ((buffer (hemlock::find-file-buffer path)))
380    (reset-display-cache (make-hemlock-display) buffer)))
381
382
383(defun edit (path)
384  (textview-for-buffer (assign-id-map-id *buffer-id-map*
385                                         (read-file-to-hemlock-buffer path))))
Note: See TracBrowser for help on using the repository browser.