| 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 | (objc:defmethod (#/getCharacters:range: :void) ((self xhemlock-buffer-string) |
|---|
| 98 | (buffer (:* :unichar)) |
|---|
| 99 | (r :<NSR>ange)) |
|---|
| 100 | (let* ((cache (hemlock-buffer-string-cache self)) |
|---|
| 101 | (index (ns:ns-range-location r)) |
|---|
| 102 | (length (ns:ns-range-length r)) |
|---|
| 103 | (hi::*current-buffer* (buffer-cache-buffer cache))) |
|---|
| 104 | #+debug |
|---|
| 105 | (#_NSLog #@"get characters: %d/%d" |
|---|
| 106 | :<NSUI>nteger index |
|---|
| 107 | :<NSUI>nteger length) |
|---|
| 108 | (multiple-value-bind (line idx) (update-line-cache-for-index cache index) |
|---|
| 109 | (let* ((len (hemlock::line-length line))) |
|---|
| 110 | (do* ((i 0 (1+ i))) |
|---|
| 111 | ((= i length)) |
|---|
| 112 | (cond ((< idx len) |
|---|
| 113 | (setf (paref buffer (:* :unichar) i) |
|---|
| 114 | (char-code (hemlock::line-character line idx))) |
|---|
| 115 | (incf idx)) |
|---|
| 116 | (t |
|---|
| 117 | (setf (paref buffer (:* :unichar) i) |
|---|
| 118 | (char-code #\Newline) |
|---|
| 119 | line (hi::line-next line) |
|---|
| 120 | len (if line (hi::line-length line) 0) |
|---|
| 121 | idx 0)))))))) |
|---|
| 122 | |
|---|
| 123 | |
|---|
| 124 | ;;; This is bound to T when we edit text using the methods of |
|---|
| 125 | ;;; NSTextStorage. These keeps the Hemlock text primitives from |
|---|
| 126 | ;;; calling edited:range:changeInLength: on their own. |
|---|
| 127 | (defvar *suppress-edit-notifications* nil) |
|---|
| 128 | |
|---|
| 129 | ;;; NSTextStorage subclass that uses a HemlockBufferString for |
|---|
| 130 | ;;; text storage, and for character attributes, too. |
|---|
| 131 | |
|---|
| 132 | (defclass xhemlock-text-storage (ns:ns-text-storage) |
|---|
| 133 | ((hemlock-string :foreign-type :id :reader hemlock-string) |
|---|
| 134 | (edit-count :foreign-type :int) |
|---|
| 135 | (selection-set-by-search :foreign-type #>BOOL)) |
|---|
| 136 | (:metaclass ns:+ns-object)) |
|---|
| 137 | |
|---|
| 138 | (defmethod (setf hemlock-string) (new (self xhemlock-text-storage)) |
|---|
| 139 | (with-slots (hemlock-string) self |
|---|
| 140 | (unless (eql hemlock-string new) |
|---|
| 141 | (#/release hemlock-string) |
|---|
| 142 | (setf hemlock-string (#/retain new))))) |
|---|
| 143 | |
|---|
| 144 | (objc:defmethod (#/dealloc :void) ((self xhemlock-text-storage)) |
|---|
| 145 | (setf (hemlock-string self) +null-ptr+) |
|---|
| 146 | (call-next-method)) |
|---|
| 147 | |
|---|
| 148 | (objc:defmethod #/hemlockString ((self xhemlock-text-storage)) |
|---|
| 149 | (slot-value self 'hemlock-string)) |
|---|
| 150 | |
|---|
| 151 | (objc:defmethod (#/updateMirror :void) ((self xhemlock-text-storage)) |
|---|
| 152 | ;; don't need to do anything |
|---|
| 153 | ) |
|---|
| 154 | |
|---|
| 155 | (defmethod hemlock-buffer ((self xhemlock-text-storage)) |
|---|
| 156 | (let ((string (hemlock-string self))) |
|---|
| 157 | (unless (%null-ptr-p string) |
|---|
| 158 | (hemlock-buffer string)))) |
|---|
| 159 | |
|---|
| 160 | (objc:defmethod #/initWithString: ((self xhemlock-text-storage) string) |
|---|
| 161 | (setq string (%inc-ptr string 0)) ;avoid stack-consed macptr? |
|---|
| 162 | (ccl::%call-next-objc-method self (find-class 'xhemlock-text-storage) |
|---|
| 163 | (@selector #/init) '(:id)) |
|---|
| 164 | (setf (slot-value self 'hemlock-string) (#/retain string)) |
|---|
| 165 | self) |
|---|
| 166 | |
|---|
| 167 | (objc:defmethod #/init ((self xhemlock-text-storage)) |
|---|
| 168 | (#/initWithString: self (make-instance 'xhemlock-buffer-string))) |
|---|
| 169 | |
|---|
| 170 | (objc:defmethod #/string ((self xhemlock-text-storage)) |
|---|
| 171 | (hemlock-string self)) |
|---|
| 172 | |
|---|
| 173 | (objc:defmethod (#/replaceCharactersInRange:withString: :void) |
|---|
| 174 | ((self xhemlock-text-storage) (range #>NSRange) string) |
|---|
| 175 | (let* ((orig-len (#/length self)) |
|---|
| 176 | (contents (hemlock-string self)) |
|---|
| 177 | (*suppress-edit-notifications* t)) |
|---|
| 178 | (#/replaceCharactersInRange:withString: contents range string) |
|---|
| 179 | (#/edited:range:changeInLength: self #$NSTextStorageEditedCharacters |
|---|
| 180 | range (- (#/length self) orig-len)))) |
|---|
| 181 | |
|---|
| 182 | (objc:defmethod (#/setAttributes:range: :void) ((self xhemlock-text-storage) |
|---|
| 183 | (attributes :id) |
|---|
| 184 | (range #>NSRange)) |
|---|
| 185 | (let* ((string (hemlock-string self)) |
|---|
| 186 | (cache (hemlock-buffer-string-cache self)) |
|---|
| 187 | (buffer (hemlock-buffer string)) |
|---|
| 188 | (hi::*current-buffer* buffer) |
|---|
| 189 | (*suppress-edit-notifications* t)) |
|---|
| 190 | (hi:with-mark ((start (hi:buffer-point buffer)) |
|---|
| 191 | (end (hi:buffer-point buffer))) |
|---|
| 192 | (move-hemlock-mark-to-absolute-position start cache |
|---|
| 193 | (ns:ns-range-location range)) |
|---|
| 194 | (move-hemlock-mark-to-absolute-position end cache |
|---|
| 195 | (+ (ns:ns-range-location range) |
|---|
| 196 | (ns:ns-range-length range))) |
|---|
| 197 | (hi::set-region-charprops (hi:region start end) (dict-to-charprops attributes)))) |
|---|
| 198 | (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes |
|---|
| 199 | range 0)) |
|---|
| 200 | |
|---|
| 201 | ;;; This appears to be called at every blink of the insertion point. |
|---|
| 202 | (objc:defmethod #/attributesAtIndex:effectiveRange: ((self xhemlock-text-storage) |
|---|
| 203 | (location #>NSUInteger) |
|---|
| 204 | (rangeptr (* #>NSRange))) |
|---|
| 205 | (let* ((buffer (hemlock-buffer (hemlock-string self))) |
|---|
| 206 | (hi::*current-buffer* buffer)) |
|---|
| 207 | (hi:with-mark ((m (hi:buffer-point buffer))) |
|---|
| 208 | (move-hemlock-mark-to-absolute-position m |
|---|
| 209 | (hemlock-buffer-string-cache |
|---|
| 210 | (hemlock-string self)) |
|---|
| 211 | location) |
|---|
| 212 | (multiple-value-bind (plist start end) |
|---|
| 213 | (hi::line-charprops-for-position (hi:mark-line m) (hi:mark-charpos m)) |
|---|
| 214 | (unless (%null-ptr-p rangeptr) |
|---|
| 215 | (let ((origin (hi::get-line-origin (hi:mark-line m)))) |
|---|
| 216 | (incf start origin) |
|---|
| 217 | (incf end origin) |
|---|
| 218 | (setf (pref rangeptr #>NSRange.location) start |
|---|
| 219 | (pref rangeptr #>NSRange.length) (- end start)))) |
|---|
| 220 | ;; This conses up a brand-new NSDictionary every time. |
|---|
| 221 | ;; Some sort of caching may be profitable here (or not...) |
|---|
| 222 | (charprops-to-dict plist))))) |
|---|
| 223 | |
|---|
| 224 | ;;; Return true iff we're inside a "beginEditing/endEditing" pair |
|---|
| 225 | (objc:defmethod (#/editingInProgress :<BOOL>) ((self xhemlock-text-storage)) |
|---|
| 226 | ;; This is meaningless outside the event thread, since you can't tell what |
|---|
| 227 | ;; other edit-count changes have already been queued up for execution on |
|---|
| 228 | ;; the event thread before it gets to whatever you might queue up next. |
|---|
| 229 | (assume-cocoa-thread) |
|---|
| 230 | (> (slot-value self 'edit-count) 0)) |
|---|
| 231 | |
|---|
| 232 | (objc:defmethod (#/noteHemlockInsertionAtPosition:length: :void) |
|---|
| 233 | ((self xhemlock-text-storage) (pos :<NSI>nteger) (n :<NSI>nteger) |
|---|
| 234 | (extra :<NSI>nteger)) |
|---|
| 235 | (declare (ignore extra)) |
|---|
| 236 | (let* ((buffer (hemlock-buffer self)) |
|---|
| 237 | (document (hi::buffer-document buffer)) |
|---|
| 238 | (undo-mgr (and document (#/undoManager document)))) |
|---|
| 239 | (when (and undo-mgr (not (#/isUndoing undo-mgr))) |
|---|
| 240 | (#/replaceCharactersInRange:withString: |
|---|
| 241 | (#/prepareWithInvocationTarget: undo-mgr self) |
|---|
| 242 | (ns:make-ns-range pos n) #@""))) |
|---|
| 243 | (let ((cache (hemlock-buffer-string-cache (hemlock-string self)))) |
|---|
| 244 | (adjust-buffer-cache-for-insertion cache pos n) |
|---|
| 245 | (update-line-cache-for-index cache pos)) |
|---|
| 246 | (unless *suppress-edit-notifications* |
|---|
| 247 | (textstorage-note-insertion-at-position self pos n))) |
|---|
| 248 | |
|---|
| 249 | (objc:defmethod (#/noteHemlockDeletionAtPosition:length: :void) |
|---|
| 250 | ((self xhemlock-text-storage) (pos :<NSI>nteger) (n :<NSI>nteger) |
|---|
| 251 | (extra :<NSI>nteger)) |
|---|
| 252 | (declare (ignorable extra)) |
|---|
| 253 | (let ((cache (hemlock-buffer-string-cache (hemlock-string self)))) |
|---|
| 254 | (reset-buffer-cache cache) |
|---|
| 255 | (update-line-cache-for-index cache pos)) |
|---|
| 256 | (unless *suppress-edit-notifications* |
|---|
| 257 | (ns:with-ns-range (range pos n) |
|---|
| 258 | (#/edited:range:changeInLength: self |
|---|
| 259 | (logior #$NSTextStorageEditedCharacters |
|---|
| 260 | #$NSTextStorageEditedAttributes) |
|---|
| 261 | range (- n))))) |
|---|
| 262 | |
|---|
| 263 | (objc:defmethod (#/noteHemlockModificationAtPosition:length: :void) |
|---|
| 264 | ((self xhemlock-text-storage) (pos :<NSI>nteger) (n :<NSI>nteger) |
|---|
| 265 | (extra :<NSI>nteger)) |
|---|
| 266 | (declare (ignorable extra)) |
|---|
| 267 | (unless *suppress-edit-notifications* |
|---|
| 268 | (ns:with-ns-range (range pos n) |
|---|
| 269 | (#/edited:range:changeInLength: self |
|---|
| 270 | (logior #$NSTextStorageEditedCharacters |
|---|
| 271 | #$NSTextStorageEditedAttributes) |
|---|
| 272 | range 0)))) |
|---|
| 273 | |
|---|
| 274 | (objc:defmethod (#/noteHemlockAttrChangeAtPosition:length: :void) |
|---|
| 275 | ((self xhemlock-text-storage) (pos :<NSI>nteger) (n :<NSI>nteger) |
|---|
| 276 | (fontnum :<NSI>nteger)) |
|---|
| 277 | (declare (ignore fontnum)) |
|---|
| 278 | (unless *suppress-edit-notifications* |
|---|
| 279 | (ns:with-ns-range (range pos n) |
|---|
| 280 | (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes |
|---|
| 281 | range 0)))) |
|---|
| 282 | |
|---|
| 283 | (defmethod assume-not-editing ((ts xhemlock-text-storage)) |
|---|
| 284 | #+debug NIL (assert (eql (slot-value ts 'edit-count) 0))) |
|---|
| 285 | |
|---|
| 286 | (defmethod update-hemlock-selection ((self xhemlock-text-storage)) |
|---|
| 287 | (assume-cocoa-thread) |
|---|
| 288 | (let ((buffer (hemlock-buffer self))) |
|---|
| 289 | (multiple-value-bind (start end) (hi:buffer-selection-range buffer) |
|---|
| 290 | #+debug |
|---|
| 291 | (#_NSLog #@"update Hemlock selection: charpos = %d, abspos = %d" |
|---|
| 292 | :int (hi::mark-charpos (hi::buffer-point buffer)) :int start) |
|---|
| 293 | (for-each-textview-using-storage |
|---|
| 294 | self |
|---|
| 295 | #'(lambda (tv) |
|---|
| 296 | (#/updateSelection:length:affinity: tv |
|---|
| 297 | start |
|---|
| 298 | (- end start) |
|---|
| 299 | (if (eql start 0) |
|---|
| 300 | #$NSSelectionAffinityUpstream |
|---|
| 301 | #$NSSelectionAffinityDownstream))))))) |
|---|
| 302 | |
|---|
| 303 | |
|---|
| 304 | ;;; Tabs are going to be a problem. |
|---|
| 305 | (defloadvar *default-paragraph-style* |
|---|
| 306 | (let* ((style (#/mutableCopy (#/defaultParagraphStyle ns:ns-paragraph-style))) |
|---|
| 307 | (charwidth (nth-value 1 (size-of-char-in-font *editor-font*)))) |
|---|
| 308 | (#/setLineBreakMode: style #$NSLineBreakByCharWrapping) |
|---|
| 309 | (#/setTabStops: style (#/array ns:ns-array)) |
|---|
| 310 | (#/setDefaultTabInterval: style (* *tab-width* charwidth)) |
|---|
| 311 | style)) |
|---|
| 312 | |
|---|
| 313 | (defun ns-color-to-charprop (color) |
|---|
| 314 | (let ((color (#/colorUsingColorSpaceName: color #&NSCalibratedRGBColorSpace))) |
|---|
| 315 | (rlet ((r #>CGFloat) |
|---|
| 316 | (g #>CGFloat) |
|---|
| 317 | (b #>CGFloat) |
|---|
| 318 | (a #>CGFloat)) |
|---|
| 319 | (#/getRed:green:blue:alpha: color r g b a) |
|---|
| 320 | (flet ((scale (f) |
|---|
| 321 | (floor (* 255 f)))) |
|---|
| 322 | (let* ((rr (scale (pref r #>CGFloat))) |
|---|
| 323 | (gg (scale (pref g #>CGFloat))) |
|---|
| 324 | (bb (scale (pref b #>CGFloat)))) |
|---|
| 325 | (format nil "#~2,'0x~2,'0x~2,'0x" rr gg bb)))))) |
|---|
| 326 | |
|---|
| 327 | (defvar *charprop-colors* (make-hash-table :test #'equalp)) |
|---|
| 328 | |
|---|
| 329 | (defun ns-color-from-charprop (color-string) |
|---|
| 330 | (or (gethash color-string *charprop-colors*) |
|---|
| 331 | (when (and (= (length color-string) 7) |
|---|
| 332 | (char= (char color-string 0) #\#)) |
|---|
| 333 | (let* ((rr (ignore-errors (parse-integer color-string :start 1 :end 3 :radix 16))) |
|---|
| 334 | (gg (ignore-errors (parse-integer color-string :start 3 :end 5 :radix 16))) |
|---|
| 335 | (bb (ignore-errors (parse-integer color-string :start 5 :end 7 :radix 16))) |
|---|
| 336 | (aa (cgfloat 1))) |
|---|
| 337 | (when (and rr gg bb) |
|---|
| 338 | (setq rr (cgfloat (/ rr 255.0)) |
|---|
| 339 | gg (cgfloat (/ gg 255.0)) |
|---|
| 340 | bb (cgfloat (/ bb 255.0))) |
|---|
| 341 | (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color |
|---|
| 342 | rr gg bb aa)))))) |
|---|
| 343 | (defun dict-to-charprops (dict) |
|---|
| 344 | (let ((enumerator (#/keyEnumerator dict)) |
|---|
| 345 | (plist nil)) |
|---|
| 346 | (loop |
|---|
| 347 | (let ((key (#/nextObject enumerator))) |
|---|
| 348 | (when (%null-ptr-p key) |
|---|
| 349 | (return plist)) |
|---|
| 350 | (let ((value (#/objectForKey: dict key)) |
|---|
| 351 | (keyword (car (rassoc key hi::*cocoa-attributes* :test #'ns-string-equal)))) |
|---|
| 352 | (case keyword |
|---|
| 353 | (:ns-font |
|---|
| 354 | (let* ((font value) |
|---|
| 355 | (descriptor (#/fontDescriptor font)) |
|---|
| 356 | (traits-mask (#/symbolicTraits descriptor)) |
|---|
| 357 | (name (lisp-string-from-nsstring (#/familyName font))) |
|---|
| 358 | (size (cgfloat (#/pointSize font)))) |
|---|
| 359 | (setq plist (nconc plist (list :font-name name :font-size size))) |
|---|
| 360 | (when (logtest traits-mask #$NSFontItalicTrait) |
|---|
| 361 | (setq plist (nconc plist (list :font-slant :italic)))) |
|---|
| 362 | (when (logtest traits-mask #$NSFontBoldTrait) |
|---|
| 363 | (setq plist (nconc plist (list :font-weight :bold)))) |
|---|
| 364 | (if (logtest traits-mask #$NSFontExpandedTrait) |
|---|
| 365 | (setq plist (nconc plist (list :font-width :exapnded))) |
|---|
| 366 | (if (logtest traits-mask #$NSFontCondensedTrait) |
|---|
| 367 | (setq plist (nconc plist (list :font-width :condensed))))))) |
|---|
| 368 | (:ns-paragraph-style ) |
|---|
| 369 | (:ns-foreground-color |
|---|
| 370 | (let* ((color value) |
|---|
| 371 | (color-string (ns-color-to-charprop color))) |
|---|
| 372 | (setq plist (nconc plist (list :font-color color-string))))) |
|---|
| 373 | (:ns-underline-style |
|---|
| 374 | (let* ((style (#/intValue value)) |
|---|
| 375 | (underline-keyword (cond ((= style #$NSUnderlineStyleSingle) |
|---|
| 376 | :single) |
|---|
| 377 | ((= style #$NSUnderlineStyleDouble) |
|---|
| 378 | :double) |
|---|
| 379 | ((= style #$NSUnderlineStyleThick) |
|---|
| 380 | :thick)))) |
|---|
| 381 | (when underline-keyword |
|---|
| 382 | (setq plist (nconc plist (list :font-underline underline-keyword)))))) |
|---|
| 383 | (:ns-superscript ) |
|---|
| 384 | (:ns-background-color |
|---|
| 385 | (let* ((color value) |
|---|
| 386 | (color-string (ns-color-to-charprop color))) |
|---|
| 387 | (setq plist (nconc plist (list :background-color color-string))))) |
|---|
| 388 | (:ns-attachment (format t "~s" keyword)) |
|---|
| 389 | (:ns-ligature (format t "~s" keyword)) |
|---|
| 390 | (:ns-baseline-offset (format t "~s" keyword)) |
|---|
| 391 | (:ns-kern (format t "~s" keyword)) |
|---|
| 392 | (:ns-link (format t "~s" keyword)) |
|---|
| 393 | (:ns-stroke-width (format t "~s" keyword)) |
|---|
| 394 | (:ns-stroke-color (format t "~s" keyword)) |
|---|
| 395 | (:ns-underline-color (format t "~s" keyword)) |
|---|
| 396 | (:ns-strikethrough-style (format t "~s" keyword)) |
|---|
| 397 | (:ns-strikethrough-color (format t "~s" keyword)) |
|---|
| 398 | (:ns-shadow (format t "~s" keyword)) |
|---|
| 399 | (:ns-obliqueness (format t "~s" keyword)) |
|---|
| 400 | (:ns-expansion (format t "~s" keyword)) |
|---|
| 401 | (:ns-cursor (format t "~s" keyword)) |
|---|
| 402 | (:ns-tool-tip (format t "~s" keyword)) |
|---|
| 403 | (:ns-character-shap (format t "~s" keyword)) |
|---|
| 404 | (:ns-glyph-info (format t "~s" keyword)))))))) |
|---|
| 405 | |
|---|
| 406 | (defun charprops-to-dict (plist) |
|---|
| 407 | (when (null plist) |
|---|
| 408 | (return-from charprops-to-dict |
|---|
| 409 | (#/dictionaryWithObjectsAndKeys: ns:ns-dictionary |
|---|
| 410 | *default-paragraph-style* |
|---|
| 411 | #&NSParagraphStyleAttributeName |
|---|
| 412 | *editor-font* |
|---|
| 413 | #&NSFontAttributeName |
|---|
| 414 | +null-ptr+))) |
|---|
| 415 | (let* ((dict (#/dictionaryWithCapacity: ns:ns-mutable-dictionary 8)) |
|---|
| 416 | (default-font *editor-font*) ;what about listeners? |
|---|
| 417 | (fm (#/sharedFontManager ns:ns-font-manager)) |
|---|
| 418 | (font +null-ptr+) |
|---|
| 419 | (font-name nil)) |
|---|
| 420 | (#/setObject:forKey: dict *default-paragraph-style* |
|---|
| 421 | #&NSParagraphStyleAttributeName) |
|---|
| 422 | (setq font-name (getf plist :font-name)) |
|---|
| 423 | (when font-name |
|---|
| 424 | (case font-name |
|---|
| 425 | (:document-font (setq font (#/userFontOfSize: ns:ns-font 0.0))) |
|---|
| 426 | (:fixed-font (setq font (#/userFixedPitchFontOfSize: ns:ns-font 0.0))) |
|---|
| 427 | (:system-font (setq font (#/systemFontOfSize: ns:ns-font 0.0))) |
|---|
| 428 | (t (setq font (#/fontWithName:size: ns:ns-font |
|---|
| 429 | (#/autorelease (%make-nsstring font-name)) |
|---|
| 430 | 0.0))))) |
|---|
| 431 | (when (%null-ptr-p font) |
|---|
| 432 | (setq font default-font)) |
|---|
| 433 | (loop for (k v) on plist by #'cddr |
|---|
| 434 | do (case k |
|---|
| 435 | (:font-size |
|---|
| 436 | (setq v (float v ns:+cgfloat-zero+)) |
|---|
| 437 | (setq font (#/convertFont:toSize: fm font v))) |
|---|
| 438 | (:font-weight |
|---|
| 439 | (cond |
|---|
| 440 | ((eq v :bold) |
|---|
| 441 | (setq font (#/convertFont:toHaveTrait: fm font #$NSBoldFontMask))) |
|---|
| 442 | ((eq v :plain) |
|---|
| 443 | (setq font (#/convertFont:toHaveTrait: fm font #$NSUnboldFontMask))))) |
|---|
| 444 | (:font-width |
|---|
| 445 | (cond |
|---|
| 446 | ((eq v :condensed) |
|---|
| 447 | (setq font (#/convertFont:toHaveTrait: fm font #$NSCondensedFontMask))) |
|---|
| 448 | ((eq v :expanded) |
|---|
| 449 | (setq font (#/convertFont:toHaveTrait: fm font #$NSExpandedFontMask))))) |
|---|
| 450 | (:font-slant |
|---|
| 451 | (cond ((eq v :italic) |
|---|
| 452 | (setq font (#/convertFont:toHaveTrait: fm font #$NSItalicFontMask))) |
|---|
| 453 | ((eq v :roman) |
|---|
| 454 | (setq font (#/convertFont:toHaveTrait: fm font #$NSUnitalicFontMask))))) |
|---|
| 455 | (:font-underline |
|---|
| 456 | (let (n) |
|---|
| 457 | (case v |
|---|
| 458 | (:single |
|---|
| 459 | (setq n (#/numberWithInt: ns:ns-number #$NSUnderlineStyleSingle))) |
|---|
| 460 | (:double |
|---|
| 461 | (setq n (#/numberWithInt: ns:ns-number #$NSUnderlineStyleDouble))) |
|---|
| 462 | (:thick |
|---|
| 463 | (setq n (#/numberWithInt: ns:ns-number #$NSUnderlineStyleThick)))) |
|---|
| 464 | (when n |
|---|
| 465 | (#/setObject:forKey: dict n #&NSUnderlineStyleAttributeName)))) |
|---|
| 466 | (:font-color |
|---|
| 467 | (let ((color (ns-color-from-charprop v))) |
|---|
| 468 | (when color |
|---|
| 469 | (#/setObject:forKey: dict color #&NSForegroundColorAttributeName)))) |
|---|
| 470 | (:background-color |
|---|
| 471 | (let ((color (ns-color-from-charprop v))) |
|---|
| 472 | (when color |
|---|
| 473 | (#/setObject:forKey: dict color #&NSBackgroundColorAttributeName)))))) |
|---|
| 474 | (unless (%null-ptr-p font) |
|---|
| 475 | (#/setObject:forKey: dict font #&NSFontAttributeName)) |
|---|
| 476 | dict)) |
|---|
| 477 | |
|---|
| 478 | (defclass xhemlock-text-view (ns:ns-text-view) |
|---|
| 479 | () |
|---|
| 480 | (:metaclass ns:+ns-object)) |
|---|
| 481 | |
|---|
| 482 | ;;; replaces version in cocoa-editor.lisp |
|---|
| 483 | |
|---|
| 484 | (defun make-textstorage-for-hemlock-buffer (buffer) |
|---|
| 485 | (make-instance 'xhemlock-text-storage |
|---|
| 486 | :with-string |
|---|
| 487 | (make-instance |
|---|
| 488 | 'xhemlock-buffer-string |
|---|
| 489 | :cache |
|---|
| 490 | (reset-buffer-cache |
|---|
| 491 | (make-buffer-cache) |
|---|
| 492 | buffer)))) |
|---|
