Changeset 556


Ignore:
Timestamp:
Feb 22, 2004, 1:21:01 AM (16 years ago)
Author:
gb
Message:

Lots of changes. Still needs event-translation work (and lots of other things.)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/examples/hemlock-textstorage.lisp

    r430 r556  
    66  (use-interface-dir :cocoa))
    77
    8 (defvar *buffer-id-map* (make-id-map))
    98
    109(defstruct hemlock-display
     
    3231
    3332(defclass hemlock-buffer-string (ns:ns-string)
    34     ((id :foreign-type :unsigned))
     33    ((display :initform nil :initarg :display :accessor hemlock-buffer-string-display))
    3534  (:metaclass ns:+ns-object))
     35
    3636
    3737(defun update-line-cache-for-index (d index)
     
    8585                     hemlock-buffer-string)
    8686  ;(#_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)))
     87  (char-code (hemlock-char-at-index (hemlock-buffer-string-display self) index)))
    8988
    9089
    9190(define-objc-method ((:unsigned length)
    9291                     hemlock-buffer-string)
    93   (let* ((display-object (id-map-object *buffer-id-map* (slot-value self 'id))))
     92  (let* ((display-object (hemlock-buffer-string-display self)))
    9493      (or (hemlock-display-buflen display-object)
    9594          (setf (hemlock-display-buflen display-object)
     
    9796
    9897
    99 (define-objc-method ((:unsigned lisp-id)
    100                      hemlock-buffer-string)
    101   (slot-value self 'id))
    10298
    10399(define-objc-method ((:id description)
    104100                     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 
     101  (let* ((d (hemlock-buffer-string-display self))
     102         (b (hemlock-display-buffer d)))
     103    (with-cstrs ((s (format nil "~a" b)))
     104      (send (@class ns-string) :string-with-format #@"<%s for %s>"
     105        (:address (#_object_getClassName self) :address s)))))
    117106
    118107                     
     
    122111  (:metaclass ns:+ns-object))
    123112
    124 
     113(define-objc-method ((:id :init-with-string s) lisp-text-storage)
     114  (let* ((newself (send-super 'init)))
     115    (setf (slot-value newself 'string) s
     116          (slot-value newself 'defaultattrs) (create-text-attributes))
     117    newself))
     118         
    125119(define-objc-method ((:id string) lisp-text-storage)
    126120  (slot-value self 'string))
     
    131125  '(#_NSLog #@"Attributes at index %d, rangeptr = %x"
    132126           :unsigned index :address rangeptr)
    133   (let* ((hemlock-display (id-map-object *buffer-id-map* (send (slot-value self 'string) 'lisp-id)))
     127  (let* ((hemlock-display (hemlock-buffer-string-display (slot-value self 'string)))
    134128         (len (hemlock-display-buflen hemlock-display)))
    135129    (if (>= index len)
     
    164158           :unsigned (pref r :<NSR>ange.length)))
    165159
    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 
    177160
    178161(define-objc-method ((:id description)
    179162                     lisp-text-storage)
    180163  (send (@class ns-string) :string-with-format #@"%s : string %@"
    181         (:address (#_object_getClassName self)
    182          :id (slot-value self 'string))))
     164        (:address (#_object_getClassName self) :id (slot-value self 'string))))
    183165
    184166
    185167(defclass lisp-text-view (ns:ns-text-view)
    186     ()
     168    ((timer :foreign-type :id :accessor blink-timer)
     169     (blink-pos :foreign-type :int :accessor blink-pos)
     170     (blink-phase :foreign-type :<BOOL> :accessor blink-phase)
     171     (blink-char :foreign-type :int :accessor blink-char))
    187172  (:metaclass ns:+ns-object))
    188173
     174(defmethod text-view-buffer ((self lisp-text-view))
     175  (hemlock-display-buffer (hemlock-buffer-string-display (send (send self 'text-storage) 'string))))
     176
     177;;; HEMLOCK-EXT::DEFINE-CLX-MODIFIER is kind of misnamed; we can use
     178;;; it to map NSEvent modifier keys to key-event modifiers.
     179(hemlock-ext::define-clx-modifier #$NSShiftKeyMask "Shift")
     180(hemlock-ext::define-clx-modifier #$NSControlKeyMask "Control")
     181(hemlock-ext::define-clx-modifier #$NSAlternateKeyMask "Meta")
     182(hemlock-ext::define-clx-modifier #$NSAlphaShiftKeyMask "Lock")
     183
     184(defun nsevent-to-key-event (nsevent)
     185  (let* ((unmodchars (send nsevent 'characters-ignoring-modifiers))
     186         (n (if (%null-ptr-p unmodchars)
     187              0
     188              (send unmodchars 'length)))
     189         (c (if (eql n 1)
     190              (send unmodchars :character-at-index 0))))
     191    (when c
     192      (let* ((bits 0)
     193             (modifiers (send nsevent 'modifier-flags)))
     194        (dolist (map hemlock-ext::*modifier-translations*)
     195          (when (logtest modifiers (car map))
     196            (setq bits (logior bits (hemlock-ext::key-event-modifier-mask
     197                                     (cdr map))))))
     198        (hemlock-ext::make-key-event c bits)))))
     199   
     200 
    189201(define-objc-method ((:void :key-down event)
    190202                     lisp-text-view)
    191   (#_NSLog #@"Key down event : %@" :address event)
    192   (send-super :key-down event))
     203  (#_NSLog #@"Key down event = %@" :address event)
     204  (format t "~& keycode = ~s~&" (send event 'key-code))
     205  (let* ((buffer (text-view-buffer self)))
     206    (when buffer
     207      (let* ((info (hemlock-frame-command-info (send self 'window))))
     208        (when info
     209          (let* ((key-event (nsevent-to-key-event event)))
     210            (when event
     211              (unless (eq buffer hi::*current-buffer*)
     212                (setf (hi::current-buffer) buffer))
     213              (hi::interpret-key-event key-event info))))))))
    193214
    194215(define-objc-method ((:void :set-selected-range (:<NSR>ange r)
     
    196217                            :still-selecting (:<BOOL> still-selecting))
    197218                     lisp-text-view)
    198   (let* ((d (id-map-object *buffer-id-map*
    199                            (send (send self 'string) 'lisp-id)))
     219  (let* ((d (hemlock-buffer-string-display (send self 'string)))
    200220         (point (hemlock::buffer-point (hemlock-display-buffer d)))
    201221         (location (pref r :<NSR>ange.location))
     
    207227                :still-selecting still-selecting)))
    208228 
    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)))
     229
     230(defun make-textstorage-for-hemlock-buffer (buffer)
     231  (setf (hi::buffer-text-storage buffer)
     232        (make-objc-instance 'lisp-text-storage
     233                            :with-string
     234                            (make-instance
     235                             'hemlock-buffer-string
     236                             :display
     237                             (reset-display-cache
     238                              (make-hemlock-display)
     239                              buffer)))))
     240
     241(defun make-scrolling-text-view-for-buffer (buffer x y width height hscroll-p)
     242  (slet ((contentrect (ns-make-rect x y width height)))
     243    (let* ((textstorage (make-textstorage-for-hemlock-buffer buffer))
     244           (scrollview (send (make-objc-instance
     245                              'ns-scroll-view
     246                              :with-frame contentrect) 'autorelease)))
    223247      (send scrollview :set-border-type #$NSBezelBorder)
    224248      (send scrollview :set-has-vertical-scroller t)
    225249      (send scrollview :set-has-horizontal-scroller hscroll-p)
    226250      (send scrollview :set-rulers-visible nil)
    227       (send scrollview :set-autoresizing-mask (logior #$NSViewWidthSizable
    228                                                       #$NSViewHeightSizable))
     251      (send scrollview :set-autoresizing-mask (logior
     252                                               #$NSViewWidthSizable
     253                                               #$NSViewHeightSizable))
    229254      (send (send scrollview 'content-view) :set-autoresizes-subviews t)
    230255      (let* ((layout (make-objc-instance 'ns-layout-manager)))
     
    233258        (slet* ((contentsize (send scrollview 'content-size))
    234259                (containersize (ns-make-size
    235                                     1.0f7
    236                                     1.0f7))
     260                                1.0f7
     261                                1.0f7))
    237262                (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
     263                           0.0f0
     264                           0.0f0
     265                           (pref contentsize :<NSS>ize.width)
     266                           (pref contentsize :<NSS>ize.height))))
     267          (let* ((container (send (make-objc-instance
    243268                                   'ns-text-container
    244269                                   :with-container-size containersize)
    245270                                  'autorelease)))
    246271            (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)))
     272            (let* ((tv (send (make-objc-instance 'lisp-text-view
     273                                                 :with-frame tv-frame
     274                                                 :text-container container)
     275                             'autorelease)))
    252276              (send tv :set-min-size (ns-make-size
    253277                                      0.0f0
     
    261285              (send container :set-height-tracks-text-view nil)
    262286              (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    
     287              (values tv scrollview))))))))
     288
     289
     290(defun make-scrolling-textview-for-view (superview buffer hscroll-p)
     291  (slet ((contentrect (send (send superview 'content-view) 'frame)))
     292    (multiple-value-bind (tv scrollview)
     293        (make-scrolling-text-view-for-buffer
     294         buffer
     295         (pref contentrect :<NSR>ect.origin.x)
     296         (pref contentrect :<NSR>ect.origin.y)
     297         (pref contentrect :<NSR>ect.size.width)
     298         (pref contentrect :<NSR>ect.size.height)
     299         hscroll-p)
     300      (send superview :set-content-view scrollview)
     301      tv)))
     302
     303(defun make-scrolling-textview-for-window (&key window buffer hscroll-p)
     304  (make-scrolling-textview-for-view (send window 'content-view) buffer hscroll-p))
     305
     306(defmethod hemlock-frame-command-info ((w ns:ns-window))
     307  nil)
     308
     309(defclass hemlock-frame (ns:ns-window)
     310    ((command-info :initform (hi::make-command-interpreter-info)
     311                   :accessor hemlock-frame-command-info))
     312  (:metaclass ns:+ns-object))
     313
     314(defmethod shared-initialize :after ((w hemlock-frame)
     315                                     slot-names
     316                                     &key &allow-other-keys)
     317  (declare (ignore slot-names))
     318  (let ((info (hemlock-frame-command-info w)))
     319    (when info
     320      (setf (hi::command-interpreter-info-frame info) w))))
    282321
    283322(defun get-cocoa-window-flag (w flagname)
     
    289328    (:auto-display
    290329     (send w 'is-autodisplay))))
    291    
     330
    292331(defun (setf get-cocoa-window-flag) (value w flagname)
    293332  (case flagname
     
    301340  (send w :make-key-and-order-front nil))
    302341
    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))
     342(defun new-hemlock-document-window (title &key
     343                                          (x 0.0)
     344                                          (y 0.0)
     345                                          (height 200.0)
     346                                          (width 500.0)
     347                                          (closable t)
     348                                          (iconifyable t)
     349                                          (metal t)
     350                                          (expandable t)
     351                                          (backing :buffered)
     352                                          (defer nil)
     353                                          (accepts-mouse-moved-events nil)
     354                                          (auto-display t)
     355                                          (activate t))
    318356  (rlet ((frame :<NSR>ect :origin.x (float x) :origin.y (float y) :size.width (float width) :size.height (float height)))
    319357    (let* ((stylemask
     
    328366              ((nil :nonretained) #$NSBackingStoreNonretained)
    329367              (:buffered #$NSBackingStoreBuffered)))
    330            (w (make-objc-instance
    331                class-name
     368           (w (make-instance
     369               'hemlock-frame
    332370               :with-content-rect frame
    333371               :style-mask stylemask
     
    340378            auto-display)
    341379      (when activate (activate-window w))
    342       w)))
    343                                            
    344 (defun textview-for-buffer (id &key (horizontal-scroll-p t))
     380      (values w (add-box-to-window w :reserve-below 20.0)))))
     381
     382(defun add-box-to-window (w &key (reserve-above 0.0f0) (reserve-below 0.0f0))
     383  (let* ((window-content-view (send w 'content-view)))
     384    (slet ((window-frame (send window-content-view 'frame)))
     385      (slet ((box-rect (ns-make-rect 0.0f0
     386                                      reserve-below
     387                                      (pref window-frame :<NSR>ect.size.width)
     388                                      (- (pref window-frame :<NSR>ect.size.height) (+ reserve-above reserve-below)))))
     389        (let* ((box (make-objc-instance 'ns-box :with-frame box-rect)))
     390          (send box :set-autoresizing-mask (logior
     391                                            #$NSViewWidthSizable
     392                                            #$NSViewHeightSizable))
     393          (send box :set-box-type #$NSBoxSecondary)
     394          (send box :set-border-type #$NSLineBorder)
     395          (send box :set-title-position #$NSBelowBottom)
     396          (send window-content-view :add-subview box)
     397          box)))))
     398         
     399                                       
     400                                     
     401(defun textview-for-hemlock-buffer (b &key (horizontal-scroll-p t))
    345402  (process-interrupt
    346403   *cocoa-event-process*
    347404   #'(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)))))))
     405      (let* ((name (hi::buffer-name b)))
     406        (multiple-value-bind (window box)
     407            (new-hemlock-document-window name :activate nil)
     408          (let* ((tv (make-scrolling-textview-for-view box
     409                                                       b
     410                                                       horizontal-scroll-p)))
     411            (multiple-value-bind (height width)
     412                (size-of-char-in-font (default-font))
     413              (size-textview-containers tv height width 24 80))
     414            (activate-window window)
     415            tv))))))
     416
    377417
    378418(defun read-file-to-hemlock-buffer (path)
    379   (let* ((buffer (hemlock::find-file-buffer path)))
    380     (reset-display-cache (make-hemlock-display) buffer)))
    381 
     419  (hemlock::find-file-buffer path))
     420
     421(defun hemlock-buffer-from-nsstring (nsstring name)
     422  (let* ((buffer (hi::make-buffer name)))
     423    (hi::delete-region (hi::buffer-region buffer))
     424    (hi::modifying-buffer buffer)
     425    (hi::with-mark ((mark (hi::buffer-point buffer) :left-inserting))
     426      (let* ((string-len (send nsstring 'length))
     427             (line-start 0)
     428             (first-line (hi::mark-line mark))
     429             (previous first-line)
     430             (buffer (hi::line-%buffer first-line)))
     431        (slet ((remaining-range (ns-make-range 0 1)))
     432          (rlet ((line-end-index :unsigned)
     433                 (contents-end-index :unsigned))
     434            (do* ((number (+ (hi::line-number first-line) hi::line-increment)
     435                          (+ number hi::line-increment)))
     436                 ((= line-start string-len))
     437              (setf (pref remaining-range :<NSR>ange.location) line-start)
     438              (send nsstring
     439                    :get-line-start (%null-ptr)
     440                    :end line-end-index
     441                    :contents-end contents-end-index
     442                    :for-range remaining-range)
     443              (let* ((contents-end (pref contents-end-index :unsigned))
     444                     (chars (make-string (- contents-end line-start))))
     445                (do* ((i line-start (1+ i))
     446                      (j 0 (1+ j)))
     447                     ((= i contents-end))
     448                  (setf (schar chars j) (code-char (send nsstring :character-at-index i))))
     449                (if (eq previous first-line)
     450                  (progn
     451                    (hi::insert-string mark chars)
     452                    (hi::insert-character mark #\newline)
     453                    (setq first-line nil))
     454                  (if (eq (pref line-end-index :unsigned) string-len)
     455                    (hi::insert-string mark chars)
     456                    (let* ((line (hi::make-line
     457                                  :previous previous
     458                                  :%buffer buffer
     459                                  :chars chars
     460                                  :number number)))
     461                      (setf (hi::line-next previous) line)
     462                      (setq previous line))))
     463                (setq line-start (pref line-end-index :unsigned))))))))
     464    buffer))
     465
     466(setq hi::*beep-function* #'(lambda (stream)
     467                              (declare (ignore stream))
     468                              (#_NSBeep)))
    382469
    383470(defun edit (path)
    384   (textview-for-buffer (assign-id-map-id *buffer-id-map*
    385                                          (read-file-to-hemlock-buffer path))))
     471  (textview-for-hemlock-buffer (read-file-to-hemlock-buffer path)))
     472
     473(defun for-each-textview-using-storage (textstorage f)
     474  (let* ((layouts (send textstorage 'layout-managers)))
     475    (unless (%null-ptr-p layouts)
     476      (dotimes (i (send layouts 'count))
     477        (let* ((layout (send layouts :object-at-index i))
     478               (containers (send layout 'text-containers)))
     479          (unless (%null-ptr-p containers)
     480            (dotimes (j (send containers 'count))
     481              (let* ((container (send containers :object-at-index j))
     482                     (tv (send container 'text-view)))
     483                (funcall f tv)))))))))
     484 
     485
     486(defun hi::textstorage-set-point-position (textstorage)
     487  (format t "~& setting point ...")
     488  (let* ((string (send textstorage 'string))
     489         (buffer (hemlock-display-buffer (hemlock-buffer-string-display string)))
     490         (point (hi::buffer-point buffer))
     491         (pos (mark-absolute-position point)))
     492    (for-each-textview-using-storage
     493     textstorage
     494     #'(lambda (tv)
     495         (send tv :set-selected-range (ns-make-range pos 0))))))
     496
     497             
     498         
Note: See TracChangeset for help on using the changeset viewer.