source: trunk/source/cocoa-ide/hemlock-text.lisp @ 12556

Last change on this file since 12556 was 12556, checked in by rme, 10 years ago

Instead of calling hi:move-to-absolute-position, use the function
move-hemlock-mark-to-absolute-position, which uses the cache.

File size: 18.9 KB
Line 
1(in-package "GUI")
2
3;;; NSMutableString subclass that uses a Hemlock buffer for
4;;; character storage.
5
6(defclass xhemlock-buffer-string (ns:ns-mutable-string)
7  ((cache :initform (reset-buffer-cache
8                     (make-buffer-cache :buffer (make-untitled-buffer)))
9          :initarg :cache :accessor hemlock-buffer-string-cache))
10  (:metaclass ns:+ns-object))
11
12(defmethod hemlock-buffer ((self xhemlock-buffer-string))
13  (with-slots (cache) self
14    (when cache
15      (buffer-cache-buffer cache))))
16
17(defvar *untitled-buffer-counter* 0)
18
19(defun next-untitled-buffer-counter ()
20  (ccl::atomic-incf *untitled-buffer-counter*))
21
22(defun make-untitled-buffer ()
23  (loop
24    (let* ((name (format nil "untitled-~d" (next-untitled-buffer-counter)))
25           (buffer (hi:make-buffer name)))
26      (when buffer
27        (return buffer)))))
28
29(objc:defmethod (#/dealloc :void) ((self xhemlock-buffer-string))
30  (let ((buffer (hemlock-buffer self)))
31    (when buffer
32      (when (eq buffer hi::*current-buffer*)
33        (setf hi::*current-buffer* nil))
34      (setf (hi::buffer-document buffer) nil)
35      ;; It makes sense to me to delete the buffer here, but
36      ;; the existing code does it in response to closing a document.
37      ;;(hi::delete-buffer buffer)
38      (setf (slot-value self 'cache) nil)
39      (call-next-method))))
40
41;;; NSMutableString primitive method
42
43(objc:defmethod (#/replaceCharactersInRange:withString: :void)
44                ((self xhemlock-buffer-string) (range #>NSRange) string)
45  (let* ((buffer (hemlock-buffer self))
46         (cache (hemlock-buffer-string-cache self))
47         (hi::*current-buffer* buffer)
48         (position (pref range #>NSRange.location))
49         (length (pref range #>NSRange.length))
50         (lisp-string (if (> (#/length string) 0) (lisp-string-from-nsstring string))))
51    (hi:with-mark ((m (hi:buffer-point buffer)))
52      (move-hemlock-mark-to-absolute-position m cache position)
53      (when (> length 0)
54        (hi:delete-characters m length))
55      (when lisp-string
56        (hi:insert-string m lisp-string)))))
57
58;;; NSString primitive methods
59
60(objc:defmethod (#/length #>NSUInteger) ((self xhemlock-buffer-string))
61  (let* ((cache (hemlock-buffer-string-cache self)))
62    (or (buffer-cache-buflen cache)
63        (setf (buffer-cache-buflen cache)
64              (let* ((buffer (buffer-cache-buffer cache)))
65                (hemlock-buffer-length buffer))))))
66
67#+slow
68(objc:defmethod (#/length #>NSUInteger) ((self xhemlock-buffer-string))
69  (let* ((buffer (hemlock-buffer self))
70         (hi::*current-buffer* buffer))
71    (hi:count-characters (hi:buffer-region buffer))))
72
73(objc:defmethod (#/characterAtIndex: :unichar) ((self xhemlock-buffer-string)
74                                                (index #>NSUInteger))
75  (char-code (hemlock-char-at-index (hemlock-buffer-string-cache self) index)))
76
77#+slow
78(objc:defmethod (#/characterAtIndex: :unichar) ((self xhemlock-buffer-string) (index #>NSUInteger))
79  (let* ((buffer (hemlock-buffer self))
80         (hi::*current-buffer* buffer)
81         (start (hi:buffer-start-mark buffer)))
82    (hi:with-mark ((m start))
83      (if (hi:character-offset m index)
84        ;; If the lisp character can't be represented as a 16-bit UTF-16
85        ;; code point (i.e., the character needs to be encoded with a surrogate
86        ;; pair), just punt and return the replacement character.  This is
87        ;; clearly not good for Gilgamesh (presumably a cuneiform user), among
88        ;; others. If we keep using the Cocoa text system, we'll have to hair
89        ;; things up to deal with this at some point.
90        (let* ((char (or (hi:next-character m)
91                         (error "index ~d out of range" index)))
92               (code (char-code char)))
93          (if (< code #x10000)
94            code
95            #\Replacement_Character))))))
96
97
98;;; This is bound to T when we edit text using the methods of
99;;; NSTextStorage.  These keeps the Hemlock text primitives from
100;;; calling edited:range:changeInLength: on their own.
101(defvar *suppress-edit-notifications* nil)
102
103;;; NSTextStorage subclass that uses a HemlockBufferString for
104;;; text storage, and for character attributes, too.
105
106(defclass xhemlock-text-storage (ns:ns-text-storage)
107  ((hemlock-string :foreign-type :id :reader hemlock-string)
108   (edit-count :foreign-type :int)
109   (selection-set-by-search :foreign-type #>BOOL))
110  (:metaclass ns:+ns-object))
111
112(defmethod (setf hemlock-string) (new (self xhemlock-text-storage))
113  (with-slots (hemlock-string) self
114    (unless (eql hemlock-string new)
115      (#/release hemlock-string)
116      (setf hemlock-string (#/retain new)))))
117
118(objc:defmethod (#/dealloc :void) ((self xhemlock-text-storage))
119  (setf (hemlock-string self) +null-ptr+)
120  (call-next-method))
121
122(objc:defmethod #/hemlockString ((self xhemlock-text-storage))
123  (slot-value self 'hemlock-string))
124
125(objc:defmethod (#/updateMirror :void) ((self xhemlock-text-storage))
126  ;; don't need to do anything
127  )
128
129(defmethod hemlock-buffer ((self xhemlock-text-storage))
130  (let ((string (hemlock-string self)))
131    (unless (%null-ptr-p string)
132      (hemlock-buffer string))))
133
134(objc:defmethod #/initWithString: ((self xhemlock-text-storage) string)
135  (setq string (%inc-ptr string 0)) ;avoid stack-consed macptr?
136  (ccl::%call-next-objc-method self (find-class 'xhemlock-text-storage)
137                               (@selector #/init) '(:id))
138  (setf (slot-value self 'hemlock-string) (#/retain string))
139  self)
140
141(objc:defmethod #/init ((self xhemlock-text-storage))
142  (#/initWithString: self (make-instance 'xhemlock-buffer-string)))
143
144(objc:defmethod #/string ((self xhemlock-text-storage))
145  (hemlock-string self))
146
147(objc:defmethod (#/replaceCharactersInRange:withString: :void)
148                ((self xhemlock-text-storage) (range #>NSRange) string)
149  (let* ((orig-len (#/length self))
150         (contents (hemlock-string self))
151         (*suppress-edit-notifications* t))
152    (#/replaceCharactersInRange:withString: contents range string)
153    (#/edited:range:changeInLength: self #$NSTextStorageEditedCharacters
154                                    range (- (#/length self) orig-len))))
155
156(objc:defmethod (#/setAttributes:range: :void) ((self xhemlock-text-storage)
157                                                (attributes :id)
158                                                (range #>NSRange))
159  (let* ((string (hemlock-string self))
160         (cache (hemlock-buffer-string-cache self))
161         (buffer (hemlock-buffer string))
162         (hi::*current-buffer* buffer)
163         (*suppress-edit-notifications* t))
164    (hi:with-mark ((start (hi:buffer-point buffer))
165                   (end (hi:buffer-point buffer)))
166      (move-hemlock-mark-to-absolute-position start cache
167                                              (ns:ns-range-location range))
168      (move-hemlock-mark-to-absolute-position end cache
169                                              (+ (ns:ns-range-location range)
170                                                 (ns:ns-range-length range)))
171      (hi::set-region-charprops (hi:region start end) (dict-to-charprops attributes))))
172  (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes
173                                  range 0))
174
175;;; This appears to be called at every blink of the insertion point.
176(objc:defmethod #/attributesAtIndex:effectiveRange: ((self xhemlock-text-storage)
177                                                     (location #>NSUInteger)
178                                                     (rangeptr (* #>NSRange)))
179  (let* ((buffer (hemlock-buffer (hemlock-string self)))
180         (hi::*current-buffer* buffer))
181    (hi:with-mark ((m (hi:buffer-point buffer)))
182      (move-hemlock-mark-to-absolute-position m
183                                              (hemlock-buffer-string-cache
184                                               (hemlock-string self))
185                                              location)
186      (multiple-value-bind (plist start end)
187                           (hi::line-charprops-for-position (hi:mark-line m) (hi:mark-charpos m))
188        (unless (%null-ptr-p rangeptr)
189          (let ((origin (hi::get-line-origin (hi:mark-line m))))
190            (incf start origin)
191            (incf end origin)
192            (setf (pref rangeptr #>NSRange.location) start
193                  (pref rangeptr #>NSRange.length) (- end start))))
194        ;; This conses up a brand-new NSDictionary every time.
195        ;; Some sort of caching may be profitable here (or not...)
196        (charprops-to-dict plist)))))
197
198;;; Return true iff we're inside a "beginEditing/endEditing" pair
199(objc:defmethod (#/editingInProgress :<BOOL>) ((self xhemlock-text-storage))
200  ;; This is meaningless outside the event thread, since you can't tell what
201  ;; other edit-count changes have already been queued up for execution on
202  ;; the event thread before it gets to whatever you might queue up next.
203  (assume-cocoa-thread)
204  (> (slot-value self 'edit-count) 0))
205
206(objc:defmethod (#/noteHemlockInsertionAtPosition:length: :void)
207    ((self xhemlock-text-storage) (pos :<NSI>nteger) (n :<NSI>nteger)
208     (extra :<NSI>nteger))
209  (declare (ignore extra))
210  (let* ((buffer (hemlock-buffer self))
211         (document (hi::buffer-document buffer))
212         (undo-mgr (and document (#/undoManager document))))
213    (when (and undo-mgr (not (#/isUndoing undo-mgr)))
214      (#/replaceCharactersInRange:withString:
215       (#/prepareWithInvocationTarget: undo-mgr self)
216       (ns:make-ns-range pos n) #@"")))
217  (let ((cache (hemlock-buffer-string-cache (hemlock-string self))))
218    (adjust-buffer-cache-for-insertion cache pos n)
219    (update-line-cache-for-index cache pos))
220  (unless *suppress-edit-notifications*
221    (textstorage-note-insertion-at-position self pos n)))
222
223(objc:defmethod (#/noteHemlockDeletionAtPosition:length: :void)
224    ((self xhemlock-text-storage) (pos :<NSI>nteger) (n :<NSI>nteger)
225     (extra :<NSI>nteger))
226  (declare (ignorable extra))
227  (let ((cache (hemlock-buffer-string-cache (hemlock-string self))))
228    (reset-buffer-cache cache)
229    (update-line-cache-for-index cache pos))
230  (unless *suppress-edit-notifications*
231    (ns:with-ns-range (range pos n)
232      (#/edited:range:changeInLength: self
233                                      (logior #$NSTextStorageEditedCharacters
234                                              #$NSTextStorageEditedAttributes)
235                                      range (- n)))))
236
237(objc:defmethod (#/noteHemlockModificationAtPosition:length: :void)
238    ((self xhemlock-text-storage) (pos :<NSI>nteger) (n :<NSI>nteger)
239     (extra :<NSI>nteger))
240  (declare (ignorable extra))
241  (unless *suppress-edit-notifications*
242    (ns:with-ns-range (range pos n)
243      (#/edited:range:changeInLength: self 
244                                      (logior #$NSTextStorageEditedCharacters
245                                              #$NSTextStorageEditedAttributes)
246                                      range 0))))
247
248(objc:defmethod (#/noteHemlockAttrChangeAtPosition:length: :void)
249    ((self xhemlock-text-storage) (pos :<NSI>nteger) (n :<NSI>nteger)
250     (fontnum :<NSI>nteger))
251  (declare (ignore fontnum))
252  (unless *suppress-edit-notifications*
253    (ns:with-ns-range (range pos n)
254      (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes
255                                      range 0))))
256
257(defmethod assume-not-editing ((ts xhemlock-text-storage))
258  #+debug NIL (assert (eql (slot-value ts 'edit-count) 0)))
259
260(defmethod update-hemlock-selection ((self xhemlock-text-storage))
261  (assume-cocoa-thread)
262  (let ((buffer (hemlock-buffer self)))
263    (multiple-value-bind (start end) (hi:buffer-selection-range buffer)
264      #+debug
265      (#_NSLog #@"update Hemlock selection: charpos = %d, abspos = %d"
266               :int (hi::mark-charpos (hi::buffer-point buffer)) :int start)
267      (for-each-textview-using-storage
268       self
269       #'(lambda (tv)
270           (#/updateSelection:length:affinity: tv
271                                               start
272                                               (- end start)
273                                               (if (eql start 0)
274                                                 #$NSSelectionAffinityUpstream
275                                                 #$NSSelectionAffinityDownstream)))))))
276
277
278;;; Tabs are going to be a problem.
279(defloadvar *default-paragraph-style*
280    (let* ((style (#/mutableCopy (#/defaultParagraphStyle ns:ns-paragraph-style)))
281           (charwidth (nth-value 1 (size-of-char-in-font *editor-font*))))
282      (#/setLineBreakMode: style #$NSLineBreakByCharWrapping)
283      (#/setTabStops: style (#/array ns:ns-array))
284      (#/setDefaultTabInterval: style (* *tab-width* charwidth))
285      style))
286
287(defun ns-color-to-charprop (color)
288  (let ((color (#/colorUsingColorSpaceName: color #&NSCalibratedRGBColorSpace)))
289    (rlet ((r #>CGFloat)
290           (g #>CGFloat)
291           (b #>CGFloat)
292           (a #>CGFloat))
293      (#/getRed:green:blue:alpha: color r g b a)
294      (flet ((scale (f)
295               (floor (* 255 f))))
296        (let* ((rr (scale (pref r #>CGFloat)))
297               (gg (scale (pref g #>CGFloat)))
298               (bb (scale (pref b #>CGFloat))))
299          (format nil "#~2,'0x~2,'0x~2,'0x" rr gg bb))))))
300
301(defun dict-to-charprops (dict)
302  (let ((enumerator (#/keyEnumerator dict))
303        (plist nil))
304    (loop
305      (let ((key (#/nextObject enumerator)))
306        (when (%null-ptr-p key)
307          (return plist))
308        (let ((value (#/objectForKey: dict key))
309              (keyword (car (rassoc key hi::*cocoa-attributes* :test #'ns-string-equal))))
310          (case keyword
311            (:ns-font
312             (let* ((font value)
313                    (descriptor (#/fontDescriptor font))
314                    (traits-mask (#/symbolicTraits descriptor))
315                    (name (lisp-string-from-nsstring (#/familyName font)))
316                    (size (cgfloat (#/pointSize font))))
317               (setq plist (nconc plist (list :font-name name :font-size size)))
318               (when (logtest traits-mask #$NSFontItalicTrait)
319                 (setq plist (nconc plist (list :font-slant :italic))))
320               (when (logtest traits-mask #$NSFontBoldTrait)
321                 (setq plist (nconc plist (list :font-weight :bold))))
322               (if (logtest traits-mask #$NSFontExpandedTrait)
323                 (setq plist (nconc plist (list :font-width :exapnded)))
324                 (if (logtest traits-mask #$NSFontCondensedTrait)
325                   (setq plist (nconc plist (list :font-width :condensed)))))))
326            (:ns-paragraph-style )
327            (:ns-foreground-color
328             (let* ((color value)
329                    (color-string (ns-color-to-charprop color)))
330               (setq plist (nconc plist (list :font-color color-string)))))
331            (:ns-underline-style
332             (let* ((style (#/intValue value))
333                    (underline-keyword (cond ((= style #$NSUnderlineStyleSingle)
334                                              :single)
335                                             ((= style #$NSUnderlineStyleDouble)
336                                              :double)
337                                             ((= style #$NSUnderlineStyleThick)
338                                              :thick))))
339               (when underline-keyword
340                 (setq plist (nconc plist (list :font-underline underline-keyword))))))
341            (:ns-superscript )
342            (:ns-background-color 
343             (let* ((color value)
344                    (color-string (ns-color-to-charprop color)))
345               (setq plist (nconc plist (list :background-color color-string)))))
346            (:ns-attachment (format t "~s" keyword))
347            (:ns-ligature (format t "~s" keyword))
348            (:ns-baseline-offset (format t "~s" keyword))
349            (:ns-kern (format t "~s" keyword))
350            (:ns-link (format t "~s" keyword))
351            (:ns-stroke-width (format t "~s" keyword))
352            (:ns-stroke-color (format t "~s" keyword))
353            (:ns-underline-color (format t "~s" keyword))
354            (:ns-strikethrough-style (format t "~s" keyword))
355            (:ns-strikethrough-color (format t "~s" keyword))
356            (:ns-shadow (format t "~s" keyword))
357            (:ns-obliqueness (format t "~s" keyword))
358            (:ns-expansion (format t "~s" keyword))
359            (:ns-cursor (format t "~s" keyword))
360            (:ns-tool-tip (format t "~s" keyword))
361            (:ns-character-shap (format t "~s" keyword))
362            (:ns-glyph-info (format t "~s" keyword))))))))
363
364     
365
366(defun charprops-to-dict (plist)
367  (when (null plist)
368    (return-from charprops-to-dict
369                 (#/dictionaryWithObjectsAndKeys: ns:ns-dictionary
370                                                  *default-paragraph-style*
371                                                  #&NSParagraphStyleAttributeName
372                                                  *editor-font*
373                                                  #&NSFontAttributeName
374                                                  +null-ptr+)))
375  (let* ((dict (#/dictionaryWithCapacity: ns:ns-mutable-dictionary 8))
376         (default-font *editor-font*)   ;what about listeners?
377         (fm (#/sharedFontManager ns:ns-font-manager))
378         (traits 0)
379         (font +null-ptr+)
380         (font-name nil))
381    (#/setObject:forKey: dict *default-paragraph-style*
382                         #&NSParagraphStyleAttributeName)
383    (setq font-name (getf plist :font-name))
384    (when font-name
385      (case font-name
386        (:document-font (setq font (#/userFontOfSize: ns:ns-font 0.0)))
387        (:fixed-font (setq font (#/userFixedPitchFontOfSize: ns:ns-font 0.0)))
388        (:system-font (setq font (#/systemFontOfSize: ns:ns-font 0.0)))
389        (t (setq font (#/fontWithName:size: ns:ns-font
390                                            (#/autorelease (%make-nsstring font-name))
391                                            0.0)))))
392    (when (%null-ptr-p font)
393      (setq font default-font))
394    (loop for (k v) on plist by #'cddr
395      do (case k
396           (:font-size (setq v (float v ns:+cgfloat-zero+))
397                       (setq font (#/convertFont:toSize: fm font v)))
398           (:font-weight (cond ((eq v :bold)
399                                (setq traits (logior traits #$NSBoldFontMask)))
400                               ((eq v :plain)
401                                (setq traits (logior traits #$NSUnboldFontMask)))))
402           (:font-width (cond ((eq v :condensed)
403                               (setq traits (logior traits #$NSCondensedFontMask)))
404                              ((eq v :expanded)
405                               (setq traits (logior traits #$NSExpandedFontMask)))))
406           (:font-slant (cond ((eq v :italic)
407                               (setq traits (logior traits #$NSItalicFontMask)))
408                              ((eq v :roman)
409                               (setq traits (logior traits #$NSUnitalicFontMask)))))
410           (:font-underline (let (n)
411                              (case v
412                                (:single
413                                 (setq n (#/numberWithInt: ns:ns-number #$NSUnderlineStyleSingle)))
414                                (:double
415                                 (setq n (#/numberWithInt: ns:ns-number #$NSUnderlineStyleDouble)))
416                                (:thick
417                                 (setq n (#/numberWithInt: ns:ns-number #$NSUnderlineStyleThick))))
418                              (when n
419                                (#/setObject:forKey: dict n #&NSUnderlineStyleAttributeName))))
420           (:font-color)
421           (:background-color)))
422    (setq font (#/convertFont:toHaveTrait: fm font traits))
423    (unless (%null-ptr-p font)
424      (#/setObject:forKey: dict font #&NSFontAttributeName))
425    dict))
426
427(defclass xhemlock-text-view (ns:ns-text-view)
428  ()
429  (:metaclass ns:+ns-object))
430
431;;; replaces version in cocoa-editor.lisp
432
433(defun make-textstorage-for-hemlock-buffer (buffer)
434  (make-instance 'xhemlock-text-storage
435                 :with-string
436                 (make-instance
437                  'xhemlock-buffer-string
438                  :cache
439                  (reset-buffer-cache
440                   (make-buffer-cache)
441                   buffer))))
Note: See TracBrowser for help on using the repository browser.