Changeset 6614


Ignore:
Timestamp:
May 25, 2007, 5:48:09 AM (18 years ago)
Author:
Gary Byers
Message:

Try to use real bold/oblique font attributes, if present. (Bold Courier
isn't much bolder than regular Courier, but ...)

Use line-origins for mark-absolute-position; should integrate with cache
mechanism.

Try to maintain a parallel NSMutableAttributedString in hemlock textstorage;
not all working yet.

Use new load/save/revert code, with encoding support. Add a popup to
the load/save panels to allow choice of encoding. (Should limit the
set - with preferences UI - since there are too many.)

Copy kill-ring to clipboard.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • branches/ide-1.0/ccl/examples/cocoa-editor.lisp

    r6589 r6614  
    4242         (font-size *default-font-size*)
    4343         (font (default-font :name font-name :size font-size))
     44         (bold-font (let* ((f (default-font :name font-name :size font-size :attributes '(:bold))))
     45                      (unless (eql f font) f)))
     46         (oblique-font (let* ((f (default-font :name font-name :size font-size :attributes '(:italic))))
     47                      (unless (eql f font) f)))
     48         (bold-oblique-font (let* ((f (default-font :name font-name :size font-size :attributes '(:bold :italic))))
     49                      (unless (eql f font) f)))
    4450         (color-class (find-class 'ns:ns-color))
    4551         (colors (vector (#/blackColor color-class)
    … …  
    5258                         (#/yellowColor color-class)))
    5359         (styles (make-array (the fixnum (* 4 (length colors)))))
    54          (bold-stroke-width 9.0f0)
     60         (bold-stroke-width 8.5f0)
     61         (fonts (vector font (or bold-font font) (or oblique-font font) (or bold-oblique-font font)))
     62         (real-fonts (vector font bold-font oblique-font bold-oblique-font))
    5563         (s 0))
    56     (declare (dynamic-extent fonts colors))
     64    (declare (dynamic-extent fonts real-fonts colors))
    5765    (dotimes (c (length colors))
    5866      (dotimes (i 4)
    59         (setf (svref styles s) (create-text-attributes :font font
    60                                                        :color (svref colors c)
    61                                                        :obliqueness
    62                                                        (if (logbitp 1 i)
    63                                                          0.15f0)
    64                                                        :stroke-width
    65                                                        (if (logbitp 0 i)
    66                                                          bold-stroke-width)))
     67        (let* ((mask (logand i 3)))
     68          (setf (svref styles s) (create-text-attributes :font (svref fonts mask)
     69                                                         :color (svref colors c)
     70                                                         :obliqueness
     71                                                         (if (logbitp 1 i)
     72                                                           (unless (svref real-fonts mask)
     73                                                             0.15f0))
     74                                                         :stroke-width
     75                                                         (if (logbitp 0 i)
     76                                                           (unless (svref real-fonts mask)
     77                                                             bold-stroke-width)))))
    6778        (incf s)))
    6879    (setq *styles* styles)))
    … …  
    148159  workline-offset                       ; cached offset of workline
    149160  workline-length                       ; length of cached workline
    150   workline-start-font-index             ; current font index at start of worklin
     161  workline-start-font-index             ; current font index at start of workline
    151162  )
    152163
    … …  
    257268         (hi::*buffer-gap-context*
    258269          (hi::buffer-gap-context (hi::line-%buffer (hi::mark-line mark)))))
    259     (do* ((line (hi::line-previous (hi::mark-line mark))
    260                 (hi::line-previous line)))
    261          ((null line) pos)
    262       (incf pos (1+ (hi::line-length line))))))
     270    (+ (hi::get-line-origin (hi::mark-line mark)) pos)))
    263271
    264272;;; Return the length of the abstract string, i.e., the number of
    … …  
    306314                       (char-code #\Newline)
    307315                       line (hi::line-next line)
    308                        len (hi::line-length line)
    309                   idx 0))))))))
     316                       len (if line (hi::line-length line))
     317                       idx 0))))))))
    310318
    311319(objc:defmethod (#/getLineStart:end:contentsEnd:forRange: :void)
    … …  
    412420    ((string :foreign-type :id)
    413421     (edit-count :foreign-type :int)
    414      (append-edits :foreign-type :int))
     422     (append-edits :foreign-type :int)
     423     (cache :foreign-type :id))
    415424  (:metaclass ns:+ns-object))
    416425
    … …  
    493502  (slot-value self 'string))
    494503
     504(objc:defmethod #/cache ((self hemlock-text-storage))
     505  (slot-value self 'cache))
     506
    495507(objc:defmethod #/initWithString: ((self hemlock-text-storage) s)
    496508  (let* ((newself (#/init self)))
    497509    (setf (slot-value newself 'string) s)
     510    (setf (slot-value newself 'cache)
     511          (#/retain (make-instance ns:ns-mutable-attributed-string
     512                                   :with-string s
     513                                   :attributes (svref *styles* 0))))
    498514    newself))
     515
     516;;; Should generally only be called after open/revert.
     517(objc:defmethod (#/updateCache :void) ((self hemlock-text-storage))
     518  (with-slots (string cache) self
     519    (#/replaceCharactersInRange:withString: cache (ns:make-ns-range 0 (#/length cache)) string)))
    499520
    500521;;; This is the only thing that's actually called to create a
    … …  
    514535    ((self hemlock-text-storage) (index :<NSUI>nteger) (rangeptr (* :<NSR>ange)))
    515536  #+debug
    516   (#_NSLog #@"Attributes at index: %ld" :<NSUI>nteger index)
     537  (#_NSLog #@"Attributes at index: %d" :unsigned index)
     538  #-no
    517539  (let* ((buffer-cache (hemlock-buffer-string-cache (slot-value self 'string)))
    518540         (buffer (buffer-cache-buffer buffer-cache))
    … …  
    533555                              (- endpos startpos)
    534556                              (hi::font-mark-font start))))))
    535       #+debug 
     557      #+debug
    536558      (#_NSLog #@"Start = %d, len = %d, style = %d"
    537559               :int start :int len :int style)
    … …  
    539561        (setf (pref rangeptr :<NSR>ange.location) start
    540562              (pref rangeptr :<NSR>ange.length) len))
    541       (svref *styles* style))))
     563      (svref *styles* style)))
     564  #+no
     565  (with-slots (cache) self
     566    (let* ((attrs (#/attributesAtIndex:effectiveRange: cache index rangeptr)))
     567      (when (eql 0 (#/count attrs))
     568        (ns:with-ns-range (r)
     569          (#/attributesAtIndex:longestEffectiveRange:inRange:
     570           cache index r (ns:make-ns-range 0 (#/length cache)))
     571          (setq attrs (svref *styles* 0))
     572          (#/setAttributes:range: cache attrs r)))
     573      attrs)))
    542574
    543575(objc:defmethod (#/replaceCharactersInRange:withString: :void)
    … …  
    558590               (setf input-mark (hi::variable-value 'hemlock::buffer-input-mark :buffer buffer))
    559591               (not (hi::same-line-p point input-mark))))
    560         (progn
    561           ;;
    562           ;;  move the point to the end of the buffer
    563           ;;
    564           (setf (hi::buffer-region-active buffer) nil)
    565           (move-hemlock-mark-to-absolute-position point cache (hemlock-buffer-length buffer)))
     592      (progn
     593        ;;
     594        ;;  move the point to the end of the buffer
     595        ;;
     596        (setf (hi::buffer-region-active buffer) nil)
     597        (move-hemlock-mark-to-absolute-position point cache (hemlock-buffer-length buffer)))
    566598      (cond ((> length 0)
    567599             (move-hemlock-mark-to-absolute-position mark cache location)
    … …  
    573605
    574606
    575 ;;; I'm not sure if we want the text system to be able to change
    576 ;;; attributes in the buffer.  This method is only here so we can
    577 ;;; see if/when it tries to do so.
    578607(objc:defmethod (#/setAttributes:range: :void) ((self hemlock-text-storage)
    579608                                                attributes
    580609                                                (r :<NSR>ange))
    581   (declare (ignorable attributes r))
    582610  #+debug
    583   (#_NSLog #@"set-attributes %@ range (%d %d)"
    584            :id attributes
    585            :unsigned (pref r :<NSR>ange.location)
    586            :unsigned (pref r :<NSR>ange.length)))
     611  (#_NSLog #@"Set attributes: %@ at %d/%d" :id attributes :int (pref r :<NSR>ange.location) :int (pref r :<NSR>ange.length))
     612  (with-slots (cache) self
     613    (#/setAttributes:range: cache attributes r)
     614    #+debug
     615    (#_NSLog #@"Assigned attributes = %@" :id (#/attributesAtIndex:effectiveRange: cache (pref r :<NSR>ange.location) +null-ptr+))
     616    ))
    587617
    588618(defun for-each-textview-using-storage (textstorage f)
    … …  
    11431173                (#/setBackgroundColor: tv color)
    11441174                (#/setSmartInsertDeleteEnabled: tv nil)
     1175                (#/setUsesFindPanel: tv t)
    11451176                (#/setWidthTracksTextView: container tracks-width)
    11461177                (#/setHeightTracksTextView: container nil)
    … …  
    15161547             (setf (hi::buffer-external-format buffer)
    15171548                   (%nsstring-to-mark nsstring mark)))
    1518 )
    15191549           (setf (hi::buffer-modified buffer) nil)
    15201550           (hi::buffer-start (hi::buffer-point buffer))
    15211551           (hi::renumber-region region)
    15221552           buffer)
    1523       (setf (hi::buffer-document buffer) document)))
     1553      (setf (hi::buffer-document buffer) document))))
    15241554
    15251555;;; This assumes that the buffer has no document and no textstorage (yet).
    … …  
    16371667
    16381668
    1639 (defun hi::buffer-note-font-change (buffer region)
     1669(defun hi::buffer-note-font-change (buffer region font)
    16401670  (when (hi::bufferp buffer)
    16411671    (let* ((document (hi::buffer-document buffer))
    16421672           (textstorage (if document (slot-value document 'textstorage)))
     1673           (cache (#/cache textstorage))
    16431674           (pos (mark-absolute-position (hi::region-start region)))
    16441675           (n (- (mark-absolute-position (hi::region-end region)) pos)))
     1676      #+debug
     1677      (#_NSLog #@"Setting font attributes for %d/%d to %@" :int pos :int n :id (svref *styles* font))
     1678      (#/setAttributes:range: cache (svref *styles* font) (ns:make-ns-range pos n))
    16451679      (perform-edit-change-notification textstorage
    16461680                                        (@selector #/noteAttrChange:)
    … …  
    16531687           (textstorage (if document (slot-value document 'textstorage))))
    16541688      (when textstorage
    1655         (let* ((pos (mark-absolute-position mark)))
     1689        (let* ((pos (mark-absolute-position mark))
     1690               (cache (#/cache textstorage))
     1691               (hemlock-string (#/string textstorage)))
    16561692          (unless (eq (hi::mark-%kind mark) :right-inserting)
    16571693            (decf pos n))
    16581694          #+debug
    16591695          (format t "~&insert: pos = ~d, n = ~d" pos n)
    1660           (let* ((display (hemlock-buffer-string-cache (#/string textstorage))))
     1696          (let* ((display (hemlock-buffer-string-cache hemlock-string)))
    16611697            ;(reset-buffer-cache display)
    16621698            (adjust-buffer-cache-for-insertion display pos n)
    16631699            (update-line-cache-for-index display pos))
     1700          (#/replaceCharactersInRange:withString:
     1701           cache (ns:make-ns-range pos 0)
     1702           (#/substringWithRange: hemlock-string (ns:make-ns-range pos n)))
    16641703          #-all-in-cocoa-thread
    16651704          (textstorage-note-insertion-at-position textstorage pos n)
    … …  
    16751714           (textstorage (if document (slot-value document 'textstorage))))
    16761715      (when textstorage
    1677         #+debug
    1678         (#_NSLog #@"enqueue modify: pos = %d, n = %d"
    1679                  :int (mark-absolute-position mark)
    1680                  :int n)
    1681         #-all-in-cocoa-thread
    1682         (#/edited:range:changeInLength:
    1683          textstorage
    1684          (logior #$NSTextStorageEditedCharacters
    1685                  #$NSTextStorageEditedAttributes)
    1686          (ns:make-ns-range (mark-absolute-position mark) n)
    1687          0)
    1688         #+all-in-cocoa-thread
    1689         (perform-edit-change-notification textstorage
    1690                                           (@selector #/noteModification:)
    1691                                           (mark-absolute-position mark)
    1692                                           n)))))
     1716        (let* ((hemlock-string (#/string textstorage))
     1717               (cache (#/cache textstorage))
     1718               (pos (mark-absolute-position mark)))
     1719          (ns:with-ns-range (range pos n)
     1720            (#/replaceCharactersInRange:withString:
     1721             cache range (#/substringWithRange: hemlock-string range))
     1722            #+debug
     1723            (#_NSLog #@"enqueue modify: pos = %d, n = %d"
     1724                     :int pos
     1725                     :int n)
     1726            #-all-in-cocoa-thread
     1727            (#/edited:range:changeInLength:
     1728             textstorage
     1729             (logior #$NSTextStorageEditedCharacters
     1730                     #$NSTextStorageEditedAttributes)
     1731             range
     1732             0)
     1733            #+all-in-cocoa-thread
     1734            (perform-edit-change-notification textstorage
     1735                                              (@selector #/noteModification:)
     1736                                              (mark-absolute-position mark)
     1737                                              n)))))))
    16931738 
    16941739
    … …  
    16981743           (textstorage (if document (slot-value document 'textstorage))))
    16991744      (when textstorage
    1700         #-all-in-cocoa-thread
    1701         (let* ((pos (mark-absolute-position mark)))
    1702           (#/edited:range:changeInLength:
    1703            textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range pos n) (- n))
    1704           (let* ((display (hemlock-buffer-string-cache (#/string textstorage))))
    1705             (reset-buffer-cache display)
    1706             (update-line-cache-for-index display pos)))
    1707         #+all-in-cocoa-thread
    1708         (perform-edit-change-notification textstorage
    1709                                           (@selector #/noteDeletion:)
    1710                                           (mark-absolute-position mark)
    1711                                           (abs n))))))
     1745        (let* ((pos (mark-absolute-position mark))
     1746               (cache (#/cache textstorage)))
     1747          #-all-in-cocoa-thread
     1748          (progn
     1749            (#/edited:range:changeInLength:
     1750             textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range pos n) (- n))
     1751            (let* ((display (hemlock-buffer-string-cache (#/string textstorage))))
     1752              (reset-buffer-cache display)
     1753              (update-line-cache-for-index display pos)))
     1754          (#/deleteCharactersInRange: cache (ns:make-ns-range pos (abs n)))
     1755          #+all-in-cocoa-thread
     1756          (perform-edit-change-notification textstorage
     1757                                            (@selector #/noteDeletion:)
     1758                                            pos
     1759                                            (abs n)))))))
    17121760
    17131761(defun hi::set-document-modified (document flag)
    … …  
    18021850  (#_NSLog #@"revert to saved from file %@ of type %@"
    18031851           :id filename :id filetype)
    1804   (let* ((data (make-instance ns:ns-data
    1805                               :with-contents-of-file filename))
     1852  (let* ((encoding (slot-value self 'encoding))
    18061853         (nsstring (make-instance ns:ns-string
    1807                                   :with-data data
    1808                                   :encoding #$NSASCIIStringEncoding))
     1854                                  :with-contents-of-file filename
     1855                                  :encoding encoding
     1856                                  :error +null-ptr+))
    18091857         (buffer (hemlock-document-buffer self))
    18101858         (old-length (hemlock-buffer-length buffer))
    … …  
    18271875                                                display
    18281876                                                (min newlen pointpos))))
     1877    (#/updateCache textstorage)
    18291878    (#/endEditing textstorage)
    18301879    (hi::document-set-point-position self)
    … …  
    18871936        (let* ((textstorage (slot-value self 'textstorage))
    18881937               (display (hemlock-buffer-string-cache (#/string textstorage))))
     1938          (#/updateCache textstorage)
    18891939          (reset-buffer-cache display)
    18901940          (update-line-cache-for-index display 0)
    … …  
    19271977    panes))
    19281978
    1929 (objc:defmethod #/dataRepresentationOfType: ((self hemlock-editor-document)
    1930                                              type)
    1931   (declare (ignorable type))
     1979
     1980
     1981(objc:defmethod (#/prepareSavePanel: :<BOOL>) ((self hemlock-editor-document)
     1982                                               panel)
     1983  (with-slots (encoding) self
     1984    (let* ((popup (build-encodings-popup (#/sharedDocumentController ns:ns-document-controller) encoding)))     
     1985      (#/setAccessoryView: panel popup)))
     1986  (#/setExtensionHidden: panel nil)
     1987  (#/setCanSelectHiddenExtension: panel nil)
     1988  (call-next-method panel))
     1989
     1990
     1991(defloadvar *ns-cr-string* (%make-nsstring (string #\return)))
     1992(defloadvar *ns-lf-string* (%make-nsstring (string #\linefeed)))
     1993(defloadvar *ns-crlf-string* (#/stringByAppendingString: *ns-cr-string* *ns-lf-string*))
     1994
     1995(objc:defmethod (#/writeToURL:ofType:error: :<BOOL>)
     1996    ((self hemlock-editor-document) url type (error (:* :id)))
     1997  (declare (ignore type))
     1998  (with-slots (encoding textstorage) self
     1999    (let* ((string (#/string textstorage))
     2000           (buffer (hemlock-document-buffer self)))
     2001      (case (when buffer (hi::buffer-external-format buffer))
     2002        (:cp/m (setq string (#/stringByReplacingOccurrencesOfString:withString:
     2003                             string *ns-lf-string* *ns-crlf-string*)))
     2004        (:macos (setq string (#/stringByReplacingOccurrencesOfString:withString:
     2005                             string *ns-lf-string* *ns-cr-string*))))
     2006      (when (#/writeToURL:atomically:encoding:error:
     2007             string url t encoding error)
     2008        (when buffer
     2009          (setf (hi::buffer-modified buffer) nil))
     2010        t))))
     2011
     2012
     2013
     2014
     2015;;; Shadow the setFileName: method, so that we can keep the buffer
     2016;;; name and pathname in synch with the document.
     2017(objc:defmethod (#/setFileURL: :void) ((self hemlock-editor-document)
     2018                                        url)
     2019  (call-next-method url)
    19322020  (let* ((buffer (hemlock-document-buffer self)))
    19332021    (when buffer
    1934       (setf (hi::buffer-modified buffer) nil)))
    1935   (#/dataUsingEncoding:allowLossyConversion:
    1936    (#/string (slot-value self 'textstorage)) #$NSASCIIStringEncoding t))
    1937 
    1938 
    1939 ;;; Shadow the setFileName: method, so that we can keep the buffer
    1940 ;;; name and pathname in synch with the document.
    1941 (objc:defmethod (#/setFileName: :void) ((self hemlock-editor-document)
    1942                                         full-path)
    1943   (call-next-method full-path)
    1944   (let* ((buffer (hemlock-document-buffer self)))
    1945     (when buffer
    1946       (let* ((new-pathname (lisp-string-from-nsstring full-path)))
     2022      (let* ((new-pathname (lisp-string-from-nsstring (#/path url))))
    19472023        (setf (hi::buffer-name buffer) (hi::pathname-to-buffer-name new-pathname))
    19482024        (setf (hi::buffer-pathname buffer) new-pathname)))))
    … …  
    21242200  (release-autorelease-pool pool))
    21252201
     2202
     2203(defloadvar *general-pasteboard* nil)
     2204
     2205(defun general-pasteboard ()
     2206  (or *general-pasteboard*
     2207      (setq *general-pasteboard*
     2208            (#/retain (#/generalPasteboard ns:ns-pasteboard)))))
     2209
     2210(defloadvar *string-pasteboard-types* ())
     2211
     2212(defun string-pasteboard-types ()
     2213  (or *string-pasteboard-types*
     2214      (setq *string-pasteboard-types*
     2215            (#/retain (#/arrayWithObject: ns:ns-array #&NSStringPboardType)))))
     2216
     2217
     2218(objc:defmethod (#/stringToPasteBoard:  :void)
     2219    ((self lisp-application) string)
     2220  (let* ((pb (general-pasteboard)))
     2221    (#/declareTypes:owner: pb (string-pasteboard-types) nil)
     2222    (#/setString:forType: pb string #&NSStringPboardType)))
     2223   
     2224(defun hi::string-to-clipboard (string)
     2225  (when (> (length string) 0)
     2226    (#/performSelectorOnMainThread:withObject:waitUntilDone:
     2227     *nsapp* (@selector #/stringToPasteBoard:) (%make-nsstring string) t)))
     2228
     2229           
     2230     
     2231 
    21262232(provide "COCOA-EDITOR")
Note: See TracChangeset for help on using the changeset viewer.