Index: /branches/ide-1.0/ccl/examples/cocoa-editor.lisp =================================================================== --- /branches/ide-1.0/ccl/examples/cocoa-editor.lisp (revision 6613) +++ /branches/ide-1.0/ccl/examples/cocoa-editor.lisp (revision 6614) @@ -42,4 +42,10 @@ (font-size *default-font-size*) (font (default-font :name font-name :size font-size)) + (bold-font (let* ((f (default-font :name font-name :size font-size :attributes '(:bold)))) + (unless (eql f font) f))) + (oblique-font (let* ((f (default-font :name font-name :size font-size :attributes '(:italic)))) + (unless (eql f font) f))) + (bold-oblique-font (let* ((f (default-font :name font-name :size font-size :attributes '(:bold :italic)))) + (unless (eql f font) f))) (color-class (find-class 'ns:ns-color)) (colors (vector (#/blackColor color-class) @@ -52,17 +58,22 @@ (#/yellowColor color-class))) (styles (make-array (the fixnum (* 4 (length colors))))) - (bold-stroke-width 9.0f0) + (bold-stroke-width 8.5f0) + (fonts (vector font (or bold-font font) (or oblique-font font) (or bold-oblique-font font))) + (real-fonts (vector font bold-font oblique-font bold-oblique-font)) (s 0)) - (declare (dynamic-extent fonts colors)) + (declare (dynamic-extent fonts real-fonts colors)) (dotimes (c (length colors)) (dotimes (i 4) - (setf (svref styles s) (create-text-attributes :font font - :color (svref colors c) - :obliqueness - (if (logbitp 1 i) - 0.15f0) - :stroke-width - (if (logbitp 0 i) - bold-stroke-width))) + (let* ((mask (logand i 3))) + (setf (svref styles s) (create-text-attributes :font (svref fonts mask) + :color (svref colors c) + :obliqueness + (if (logbitp 1 i) + (unless (svref real-fonts mask) + 0.15f0)) + :stroke-width + (if (logbitp 0 i) + (unless (svref real-fonts mask) + bold-stroke-width))))) (incf s))) (setq *styles* styles))) @@ -148,5 +159,5 @@ workline-offset ; cached offset of workline workline-length ; length of cached workline - workline-start-font-index ; current font index at start of worklin + workline-start-font-index ; current font index at start of workline ) @@ -257,8 +268,5 @@ (hi::*buffer-gap-context* (hi::buffer-gap-context (hi::line-%buffer (hi::mark-line mark))))) - (do* ((line (hi::line-previous (hi::mark-line mark)) - (hi::line-previous line))) - ((null line) pos) - (incf pos (1+ (hi::line-length line)))))) + (+ (hi::get-line-origin (hi::mark-line mark)) pos))) ;;; Return the length of the abstract string, i.e., the number of @@ -306,6 +314,6 @@ (char-code #\Newline) line (hi::line-next line) - len (hi::line-length line) - idx 0)))))))) + len (if line (hi::line-length line)) + idx 0)))))))) (objc:defmethod (#/getLineStart:end:contentsEnd:forRange: :void) @@ -412,5 +420,6 @@ ((string :foreign-type :id) (edit-count :foreign-type :int) - (append-edits :foreign-type :int)) + (append-edits :foreign-type :int) + (cache :foreign-type :id)) (:metaclass ns:+ns-object)) @@ -493,8 +502,20 @@ (slot-value self 'string)) +(objc:defmethod #/cache ((self hemlock-text-storage)) + (slot-value self 'cache)) + (objc:defmethod #/initWithString: ((self hemlock-text-storage) s) (let* ((newself (#/init self))) (setf (slot-value newself 'string) s) + (setf (slot-value newself 'cache) + (#/retain (make-instance ns:ns-mutable-attributed-string + :with-string s + :attributes (svref *styles* 0)))) newself)) + +;;; Should generally only be called after open/revert. +(objc:defmethod (#/updateCache :void) ((self hemlock-text-storage)) + (with-slots (string cache) self + (#/replaceCharactersInRange:withString: cache (ns:make-ns-range 0 (#/length cache)) string))) ;;; This is the only thing that's actually called to create a @@ -514,5 +535,6 @@ ((self hemlock-text-storage) (index :nteger) (rangeptr (* :ange))) #+debug - (#_NSLog #@"Attributes at index: %ld" :nteger index) + (#_NSLog #@"Attributes at index: %d" :unsigned index) + #-no (let* ((buffer-cache (hemlock-buffer-string-cache (slot-value self 'string))) (buffer (buffer-cache-buffer buffer-cache)) @@ -533,5 +555,5 @@ (- endpos startpos) (hi::font-mark-font start)))))) - #+debug + #+debug (#_NSLog #@"Start = %d, len = %d, style = %d" :int start :int len :int style) @@ -539,5 +561,15 @@ (setf (pref rangeptr :ange.location) start (pref rangeptr :ange.length) len)) - (svref *styles* style)))) + (svref *styles* style))) + #+no + (with-slots (cache) self + (let* ((attrs (#/attributesAtIndex:effectiveRange: cache index rangeptr))) + (when (eql 0 (#/count attrs)) + (ns:with-ns-range (r) + (#/attributesAtIndex:longestEffectiveRange:inRange: + cache index r (ns:make-ns-range 0 (#/length cache))) + (setq attrs (svref *styles* 0)) + (#/setAttributes:range: cache attrs r))) + attrs))) (objc:defmethod (#/replaceCharactersInRange:withString: :void) @@ -558,10 +590,10 @@ (setf input-mark (hi::variable-value 'hemlock::buffer-input-mark :buffer buffer)) (not (hi::same-line-p point input-mark)))) - (progn - ;; - ;; move the point to the end of the buffer - ;; - (setf (hi::buffer-region-active buffer) nil) - (move-hemlock-mark-to-absolute-position point cache (hemlock-buffer-length buffer))) + (progn + ;; + ;; move the point to the end of the buffer + ;; + (setf (hi::buffer-region-active buffer) nil) + (move-hemlock-mark-to-absolute-position point cache (hemlock-buffer-length buffer))) (cond ((> length 0) (move-hemlock-mark-to-absolute-position mark cache location) @@ -573,16 +605,14 @@ -;;; I'm not sure if we want the text system to be able to change -;;; attributes in the buffer. This method is only here so we can -;;; see if/when it tries to do so. (objc:defmethod (#/setAttributes:range: :void) ((self hemlock-text-storage) attributes (r :ange)) - (declare (ignorable attributes r)) #+debug - (#_NSLog #@"set-attributes %@ range (%d %d)" - :id attributes - :unsigned (pref r :ange.location) - :unsigned (pref r :ange.length))) + (#_NSLog #@"Set attributes: %@ at %d/%d" :id attributes :int (pref r :ange.location) :int (pref r :ange.length)) + (with-slots (cache) self + (#/setAttributes:range: cache attributes r) + #+debug + (#_NSLog #@"Assigned attributes = %@" :id (#/attributesAtIndex:effectiveRange: cache (pref r :ange.location) +null-ptr+)) + )) (defun for-each-textview-using-storage (textstorage f) @@ -1143,4 +1173,5 @@ (#/setBackgroundColor: tv color) (#/setSmartInsertDeleteEnabled: tv nil) + (#/setUsesFindPanel: tv t) (#/setWidthTracksTextView: container tracks-width) (#/setHeightTracksTextView: container nil) @@ -1516,10 +1547,9 @@ (setf (hi::buffer-external-format buffer) (%nsstring-to-mark nsstring mark))) -) (setf (hi::buffer-modified buffer) nil) (hi::buffer-start (hi::buffer-point buffer)) (hi::renumber-region region) buffer) - (setf (hi::buffer-document buffer) document))) + (setf (hi::buffer-document buffer) document)))) ;;; This assumes that the buffer has no document and no textstorage (yet). @@ -1637,10 +1667,14 @@ -(defun hi::buffer-note-font-change (buffer region) +(defun hi::buffer-note-font-change (buffer region font) (when (hi::bufferp buffer) (let* ((document (hi::buffer-document buffer)) (textstorage (if document (slot-value document 'textstorage))) + (cache (#/cache textstorage)) (pos (mark-absolute-position (hi::region-start region))) (n (- (mark-absolute-position (hi::region-end region)) pos))) + #+debug + (#_NSLog #@"Setting font attributes for %d/%d to %@" :int pos :int n :id (svref *styles* font)) + (#/setAttributes:range: cache (svref *styles* font) (ns:make-ns-range pos n)) (perform-edit-change-notification textstorage (@selector #/noteAttrChange:) @@ -1653,13 +1687,18 @@ (textstorage (if document (slot-value document 'textstorage)))) (when textstorage - (let* ((pos (mark-absolute-position mark))) + (let* ((pos (mark-absolute-position mark)) + (cache (#/cache textstorage)) + (hemlock-string (#/string textstorage))) (unless (eq (hi::mark-%kind mark) :right-inserting) (decf pos n)) #+debug (format t "~&insert: pos = ~d, n = ~d" pos n) - (let* ((display (hemlock-buffer-string-cache (#/string textstorage)))) + (let* ((display (hemlock-buffer-string-cache hemlock-string))) ;(reset-buffer-cache display) (adjust-buffer-cache-for-insertion display pos n) (update-line-cache-for-index display pos)) + (#/replaceCharactersInRange:withString: + cache (ns:make-ns-range pos 0) + (#/substringWithRange: hemlock-string (ns:make-ns-range pos n))) #-all-in-cocoa-thread (textstorage-note-insertion-at-position textstorage pos n) @@ -1675,20 +1714,26 @@ (textstorage (if document (slot-value document 'textstorage)))) (when textstorage - #+debug - (#_NSLog #@"enqueue modify: pos = %d, n = %d" - :int (mark-absolute-position mark) - :int n) - #-all-in-cocoa-thread - (#/edited:range:changeInLength: - textstorage - (logior #$NSTextStorageEditedCharacters - #$NSTextStorageEditedAttributes) - (ns:make-ns-range (mark-absolute-position mark) n) - 0) - #+all-in-cocoa-thread - (perform-edit-change-notification textstorage - (@selector #/noteModification:) - (mark-absolute-position mark) - n))))) + (let* ((hemlock-string (#/string textstorage)) + (cache (#/cache textstorage)) + (pos (mark-absolute-position mark))) + (ns:with-ns-range (range pos n) + (#/replaceCharactersInRange:withString: + cache range (#/substringWithRange: hemlock-string range)) + #+debug + (#_NSLog #@"enqueue modify: pos = %d, n = %d" + :int pos + :int n) + #-all-in-cocoa-thread + (#/edited:range:changeInLength: + textstorage + (logior #$NSTextStorageEditedCharacters + #$NSTextStorageEditedAttributes) + range + 0) + #+all-in-cocoa-thread + (perform-edit-change-notification textstorage + (@selector #/noteModification:) + (mark-absolute-position mark) + n))))))) @@ -1698,16 +1743,19 @@ (textstorage (if document (slot-value document 'textstorage)))) (when textstorage - #-all-in-cocoa-thread - (let* ((pos (mark-absolute-position mark))) - (#/edited:range:changeInLength: - textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range pos n) (- n)) - (let* ((display (hemlock-buffer-string-cache (#/string textstorage)))) - (reset-buffer-cache display) - (update-line-cache-for-index display pos))) - #+all-in-cocoa-thread - (perform-edit-change-notification textstorage - (@selector #/noteDeletion:) - (mark-absolute-position mark) - (abs n)))))) + (let* ((pos (mark-absolute-position mark)) + (cache (#/cache textstorage))) + #-all-in-cocoa-thread + (progn + (#/edited:range:changeInLength: + textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range pos n) (- n)) + (let* ((display (hemlock-buffer-string-cache (#/string textstorage)))) + (reset-buffer-cache display) + (update-line-cache-for-index display pos))) + (#/deleteCharactersInRange: cache (ns:make-ns-range pos (abs n))) + #+all-in-cocoa-thread + (perform-edit-change-notification textstorage + (@selector #/noteDeletion:) + pos + (abs n))))))) (defun hi::set-document-modified (document flag) @@ -1802,9 +1850,9 @@ (#_NSLog #@"revert to saved from file %@ of type %@" :id filename :id filetype) - (let* ((data (make-instance ns:ns-data - :with-contents-of-file filename)) + (let* ((encoding (slot-value self 'encoding)) (nsstring (make-instance ns:ns-string - :with-data data - :encoding #$NSASCIIStringEncoding)) + :with-contents-of-file filename + :encoding encoding + :error +null-ptr+)) (buffer (hemlock-document-buffer self)) (old-length (hemlock-buffer-length buffer)) @@ -1827,4 +1875,5 @@ display (min newlen pointpos)))) + (#/updateCache textstorage) (#/endEditing textstorage) (hi::document-set-point-position self) @@ -1887,4 +1936,5 @@ (let* ((textstorage (slot-value self 'textstorage)) (display (hemlock-buffer-string-cache (#/string textstorage)))) + (#/updateCache textstorage) (reset-buffer-cache display) (update-line-cache-for-index display 0) @@ -1927,22 +1977,48 @@ panes)) -(objc:defmethod #/dataRepresentationOfType: ((self hemlock-editor-document) - type) - (declare (ignorable type)) + + +(objc:defmethod (#/prepareSavePanel: :) ((self hemlock-editor-document) + panel) + (with-slots (encoding) self + (let* ((popup (build-encodings-popup (#/sharedDocumentController ns:ns-document-controller) encoding))) + (#/setAccessoryView: panel popup))) + (#/setExtensionHidden: panel nil) + (#/setCanSelectHiddenExtension: panel nil) + (call-next-method panel)) + + +(defloadvar *ns-cr-string* (%make-nsstring (string #\return))) +(defloadvar *ns-lf-string* (%make-nsstring (string #\linefeed))) +(defloadvar *ns-crlf-string* (#/stringByAppendingString: *ns-cr-string* *ns-lf-string*)) + +(objc:defmethod (#/writeToURL:ofType:error: :) + ((self hemlock-editor-document) url type (error (:* :id))) + (declare (ignore type)) + (with-slots (encoding textstorage) self + (let* ((string (#/string textstorage)) + (buffer (hemlock-document-buffer self))) + (case (when buffer (hi::buffer-external-format buffer)) + (:cp/m (setq string (#/stringByReplacingOccurrencesOfString:withString: + string *ns-lf-string* *ns-crlf-string*))) + (:macos (setq string (#/stringByReplacingOccurrencesOfString:withString: + string *ns-lf-string* *ns-cr-string*)))) + (when (#/writeToURL:atomically:encoding:error: + string url t encoding error) + (when buffer + (setf (hi::buffer-modified buffer) nil)) + t)))) + + + + +;;; Shadow the setFileName: method, so that we can keep the buffer +;;; name and pathname in synch with the document. +(objc:defmethod (#/setFileURL: :void) ((self hemlock-editor-document) + url) + (call-next-method url) (let* ((buffer (hemlock-document-buffer self))) (when buffer - (setf (hi::buffer-modified buffer) nil))) - (#/dataUsingEncoding:allowLossyConversion: - (#/string (slot-value self 'textstorage)) #$NSASCIIStringEncoding t)) - - -;;; Shadow the setFileName: method, so that we can keep the buffer -;;; name and pathname in synch with the document. -(objc:defmethod (#/setFileName: :void) ((self hemlock-editor-document) - full-path) - (call-next-method full-path) - (let* ((buffer (hemlock-document-buffer self))) - (when buffer - (let* ((new-pathname (lisp-string-from-nsstring full-path))) + (let* ((new-pathname (lisp-string-from-nsstring (#/path url)))) (setf (hi::buffer-name buffer) (hi::pathname-to-buffer-name new-pathname)) (setf (hi::buffer-pathname buffer) new-pathname))))) @@ -2124,3 +2200,33 @@ (release-autorelease-pool pool)) + +(defloadvar *general-pasteboard* nil) + +(defun general-pasteboard () + (or *general-pasteboard* + (setq *general-pasteboard* + (#/retain (#/generalPasteboard ns:ns-pasteboard))))) + +(defloadvar *string-pasteboard-types* ()) + +(defun string-pasteboard-types () + (or *string-pasteboard-types* + (setq *string-pasteboard-types* + (#/retain (#/arrayWithObject: ns:ns-array #&NSStringPboardType))))) + + +(objc:defmethod (#/stringToPasteBoard: :void) + ((self lisp-application) string) + (let* ((pb (general-pasteboard))) + (#/declareTypes:owner: pb (string-pasteboard-types) nil) + (#/setString:forType: pb string #&NSStringPboardType))) + +(defun hi::string-to-clipboard (string) + (when (> (length string) 0) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + *nsapp* (@selector #/stringToPasteBoard:) (%make-nsstring string) t))) + + + + (provide "COCOA-EDITOR")