Changeset 15906


Ignore:
Timestamp:
Sep 20, 2013, 5:57:41 PM (8 years ago)
Author:
gz
Message:

Introduced a new convention: symbols exported from the HEMLOCK package are there for the IDE to use. Added a new hemlock file, display.lisp, which defines a set of such functions, mostly code that used to be in the IDE but had no actual Cocoa dependencies - we now have hemlock:update-current-package, hemlock:paren-matching-bounds, hemlock:selection-for-click, hemlock:move-point-for-click, and hemlock:compute-syntax-coloring.

New fn hemlock-ext:lookup-color maps a color description to a Cocoa color object. The current implementation is rudimentary, I'm hoping someone can make
it more real.

Extended hemlock:compute-syntax-coloring to add coloring for symbols. This fixes ticket:125.
To change how symbol colors get decided, you're most likely to want to modify some of:

hemlock::compute-symbol-category
hemlock::defining-symbol-p
hemlock::*lisp-code-colors*

Location:
trunk/source/cocoa-ide
Files:
1 added
7 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/cocoa-ide/cocoa-editor.lisp

    r15886 r15906  
    11831183    (remove-paren-highlight self)))
    11841184
     1185(defun hemlock-ext:lookup-color (color-spec)
     1186  (etypecase color-spec
     1187    (cons (apply #'color-values-to-nscolor color-spec))
     1188    ((vector t) (apply #'color-values-to-nscolor (coerce color-spec 'list)))
     1189    ((or string symbol)
     1190     (let ((name (string color-spec)))
     1191       ;; Please rewrite me...
     1192       (cond ((string-equal name "black") (#/blackColor ns:ns-color))
     1193             ((string-equal name "blue") (#/blueColor ns:ns-color))
     1194             ((string-equal name "brown") (#/brownColor ns:ns-color))
     1195             ((string-equal name "cyan") (#/cyanColor ns:ns-color))
     1196             ((string-equal name "gray") (#/grayColor ns:ns-color))
     1197             ((string-equal name "lightgray") (#/lightGrayColor ns:ns-color))
     1198             ((string-equal name "darkgray") (#/darkGrayColor ns:ns-color))       
     1199             ((string-equal name "green") (#/greenColor ns:ns-color))
     1200             ((string-equal name "magenta") (#/magentaColor ns:ns-color))
     1201             ((string-equal name "orange") (#/orangeColor ns:ns-color))
     1202             ((string-equal name "purple") (#/purpleColor ns:ns-color))
     1203             ((string-equal name "red") (#/redColor ns:ns-color))
     1204             ((string-equal name "white") (#/whiteColor ns:ns-color))
     1205             ((string-equal name "yellow") (#/yellowColor ns:ns-color))
     1206             (t (error "I don't know color ~s" name)))))))
     1207
    11851208
    11861209(defmethod compute-temporary-attributes ((self hemlock-textstorage-text-view))
     
    12051228      (#/removeTemporaryAttribute:forCharacterRange:
    12061229       layout #&NSBackgroundColorAttributeName char-range)
    1207       (let* ((ts (#/textStorage self))
    1208              (cache (hemlock-buffer-string-cache (slot-value ts 'hemlock-string)))
    1209              (hi::*current-buffer* (buffer-cache-buffer cache)))
    1210         (multiple-value-bind (start-line start-offset)
    1211             (update-line-cache-for-index cache start)
    1212           (let* ((end-line (update-line-cache-for-index cache (+ start length))))
    1213             (set-temporary-character-attributes
    1214              layout
    1215              (- start start-offset)
    1216              start-line
    1217              (hi::line-next end-line)))))))
     1230      (hemlock:with-display-context (hemlock-view self)
     1231        (ns:with-ns-range (range)
     1232          (loop
     1233            for (start len . color) in (hemlock:compute-syntax-coloring start length)
     1234            when color
     1235            do (progn
     1236                 (setf (ns:ns-range-location range) start
     1237                       (ns:ns-range-length range) len)
     1238                 (#/addTemporaryAttribute:value:forCharacterRange:
     1239                  layout #&NSForegroundColorAttributeName color range)))))))
    12181240  (when (eql #$YES (text-view-paren-highlight-enabled self))
    12191241    (let* ((background #&NSBackgroundColorAttributeName)
     
    12391261(defmethod update-paren-highlight ((self hemlock-textstorage-text-view))
    12401262  (disable-paren-highlight self)
    1241   (let* ((buffer (hemlock-buffer self)))
    1242     (when (and buffer (string= (hi::buffer-major-mode buffer) "Lisp"))
    1243       (let* ((hi::*current-buffer* buffer)
    1244              (point (hi::buffer-point buffer)))
     1263  (let* ((view (hemlock-view self))
     1264         (buffer (and view (hi:hemlock-view-buffer view))))
     1265    (when (and buffer (string= (hi:buffer-major-mode buffer) "Lisp"))
     1266      (hemlock:with-display-context view
    12451267        #+debug (#_NSLog #@"Syntax check for paren-highlighting")
    1246         (update-buffer-package (hi::buffer-document buffer) buffer)
    1247         (cond ((eql (hi::next-character point) #\()
    1248                (hemlock::pre-command-parse-check point)
    1249                (when (hemlock::valid-spot point t)
    1250                  (hi::with-mark ((temp point))
    1251                    (when (hemlock::list-offset temp 1)
    1252                      #+debug (#_NSLog #@"enable paren-highlight, forward")
    1253                      (setf (text-view-paren-highlight-right-pos self)
    1254                            (1- (hi:mark-absolute-position temp))
    1255                            (text-view-paren-highlight-left-pos self)
    1256                            (hi::mark-absolute-position point)
    1257                            (text-view-paren-highlight-enabled self) #$YES)))))
    1258               ((eql (hi::previous-character point) #\))
    1259                (hemlock::pre-command-parse-check point)
    1260                (when (hemlock::valid-spot point nil)
    1261                  (hi::with-mark ((temp point))
    1262                    (when (hemlock::list-offset temp -1)
    1263                      #+debug (#_NSLog #@"enable paren-highlight, backward")
    1264                      (setf (text-view-paren-highlight-left-pos self)
    1265                            (hi:mark-absolute-position temp)
    1266                            (text-view-paren-highlight-right-pos self)
    1267                            (1- (hi:mark-absolute-position point))
    1268                            (text-view-paren-highlight-enabled self) #$YES))))))
    1269         (compute-temporary-attributes self)))))
     1268        (update-buffer-package (hi::buffer-document buffer))
     1269        (multiple-value-bind (left right) (hemlock:paren-matching-bounds)
     1270          (when (and left right)
     1271            (setf (text-view-paren-highlight-left-pos self) left
     1272                  (text-view-paren-highlight-right-pos self) right
     1273                  (text-view-paren-highlight-enabled self) #$YES))))
     1274      (compute-temporary-attributes self))))
    12701275
    12711276
     
    13271332
    13281333
    1329 (defloadvar *lisp-string-color* (#/blueColor ns:ns-color))
    1330 (defloadvar *lisp-comment-color* (#/brownColor ns:ns-color))
    1331 (defloadvar *lisp-double-comment-color* (#/orangeColor ns:ns-color))
    1332 (defloadvar *lisp-triple-comment-color* (#/redColor ns:ns-color))
    1333 
    1334 
    1335 ;;; LAYOUT is an NSLayoutManager in which we'll set temporary character
    1336 ;;; attrubutes before redisplay.
    1337 ;;; POS is the absolute character position of the start of START-LINE.
    1338 ;;; END-LINE is either EQ to START-LINE (in the degenerate case) or
    1339 ;;; follows it in the buffer; it may be NIL and is the exclusive
    1340 ;;; end of a range of lines
    1341 ;;; HI::*CURRENT-BUFFER* is bound to the buffer containing START-LINE
    1342 ;;; and END-LINE
    1343 #-cocotron
    1344 (defun set-temporary-character-attributes (layout pos start-line end-line)
    1345   (ns:with-ns-range (range)
    1346     (let* ((color-attribute #&NSForegroundColorAttributeName)
    1347            (string-color  *lisp-string-color* )
    1348            (comment-color *lisp-comment-color*)
    1349            (double-comment-color *lisp-double-comment-color*)
    1350            (triple-comment-color *lisp-triple-comment-color*))
    1351       (hi::with-mark ((m (hi::buffer-start-mark hi::*current-buffer*)))
    1352         (hi::line-start m start-line)
    1353         (hi::pre-command-parse-check m))
    1354       (do ((p pos (+ p (1+ (hi::line-length line))))
    1355            (line start-line (hi::line-next line)))
    1356           ((eq line end-line))
    1357         (let* ((parse-info (getf (hi::line-plist line) 'hemlock::lisp-info))
    1358                (last-end 0))
    1359           (when parse-info
    1360             (dolist (r (hemlock::lisp-info-ranges-to-ignore parse-info))
    1361               (destructuring-bind (istart . iend) r
    1362                 (let* ((attr (if (= istart 0)
    1363                                (hemlock::lisp-info-begins-quoted parse-info)
    1364                                (if (< last-end istart)
    1365                                  (hi:character-attribute :lisp-syntax
    1366                                                          (hi::line-character line (1- istart)))
    1367                                  :comment)))
    1368                        (type (case attr
    1369                                ((:char-quote :symbol-quote) nil)
    1370                                (:string-quote :string)
    1371                                (t :comment)))
    1372                        (start (+ p istart))
    1373                        (len (- iend istart))
    1374                        (nsemi (if (eq type :comment)
    1375                                 (do* ((n 0)
    1376                                       (i istart (1+ i)))
    1377                                      ((= i iend) n)
    1378                                   (unless (eq
    1379                                            (hi:character-attribute :lisp-syntax
    1380                                                                    (hi::line-character line i))
    1381                                            :comment)
    1382                                     (return n))
    1383                                   (when (= (incf n) 3)
    1384                                     (return n))))))
    1385                   (when type
    1386                     (when (eq type :string)
    1387                       (decf start)
    1388                       (incf len 2))
    1389                     (setf (ns:ns-range-location range) start
    1390                           (ns:ns-range-length range) len)
    1391                     (let ((attrs (if (eq type :string)
    1392                                    string-color
    1393                                    (case nsemi
    1394                                      (2 double-comment-color)
    1395                                      (3 triple-comment-color)
    1396                                      (t comment-color)))))
    1397                       (#/addTemporaryAttribute:value:forCharacterRange:
    1398                        layout color-attribute attrs range)))
    1399                   (setq last-end iend))))))))))
    1400 
    1401 #+no
    1402 (objc:defmethod (#/drawRect: :void) ((self hemlock-text-view) (rect :<NSR>ect))
    1403   ;; Um, don't forget to actually draw the view..
    1404   (call-next-method  rect))
    1405 
    1406 
    1407 
    14081334(defmethod hemlock-view ((self hemlock-text-view))
    14091335  (slot-value self 'hemlock-view))
     
    14161342                                         (hemlock::editor-execute-expression-command nil))))))
    14171343
     1344(defun ui-buffer-env (obj)
     1345  (let* ((buffer (hemlock-buffer obj))
     1346         (package-name (hi::variable-value 'hemlock::default-package :buffer buffer))
     1347         (pathname (hi::buffer-pathname buffer)))
     1348    (list package-name pathname)))
     1349
    14181350(objc:defmethod (#/evalAll: :void) ((self hemlock-text-view) sender)
    14191351  (declare (ignore sender))
    1420   (let* ((buffer (hemlock-buffer self))
    1421          (package-name (hi::variable-value 'hemlock::default-package :buffer buffer))
    1422          (pathname (hi::buffer-pathname buffer))
    1423          (s (lisp-string-from-nsstring (#/string self))))
    1424     (ui-object-eval-selection *NSApp* (list package-name pathname s))))
     1352  (let* ((s (lisp-string-from-nsstring (#/string self))))
     1353    (ui-object-eval-selection *NSApp* `(,@(ui-buffer-env self) ,s))))
    14251354
    14261355(objc:defmethod (#/loadBuffer: :void) ((self hemlock-text-view) sender)
    14271356  (declare (ignore sender))
    1428   (let* ((buffer (hemlock-buffer self))
    1429          (package-name (hi::variable-value 'hemlock::default-package :buffer buffer))
    1430          (pathname (hi::buffer-pathname buffer)))
    1431     (ui-object-load-buffer *NSApp* (list package-name pathname))))
     1357  (ui-object-load-buffer *NSApp* (ui-buffer-env self)))
    14321358
    14331359(objc:defmethod (#/compileBuffer: :void) ((self hemlock-text-view) sender)
    14341360  (declare (ignore sender))
    1435   (let* ((buffer (hemlock-buffer self))
    1436          (package-name (hi::variable-value 'hemlock::default-package :buffer buffer))
    1437          (pathname (hi::buffer-pathname buffer)))
    1438     (ui-object-compile-buffer *NSApp* (list package-name pathname))))
     1361  (ui-object-compile-buffer *NSApp* (ui-buffer-env self)))
    14391362
    14401363(objc:defmethod (#/compileAndLoadBuffer: :void) ((self hemlock-text-view) sender)
    14411364  (declare (ignore sender))
    1442   (let* ((buffer (hemlock-buffer self))
    1443          (package-name (hi::variable-value 'hemlock::default-package :buffer buffer))
    1444          (pathname (hi::buffer-pathname buffer)))
    1445     (ui-object-compile-and-load-buffer *NSApp* (list package-name pathname))))
     1365  (ui-object-compile-and-load-buffer *NSApp* (ui-buffer-env self)))
    14461366
    14471367(defloadvar *text-view-context-menu* ())
     
    15791499                (hi:with-mark ((mark point))
    15801500                  (when (or (= length 0) (hi:move-to-absolute-position mark index))
    1581                     (let* ((region (selection-for-click mark atom-mode))
     1501                    (let* ((region (hemlock:selection-for-click mark atom-mode))
    15821502                           (other-region (and (< 0 length)
    15831503                                              (hi:character-offset mark length)
    1584                                               (selection-for-click mark atom-mode))))
     1504                                              (hemlock:selection-for-click mark atom-mode))))
    15851505                      (when (null region) (setq region other-region other-region nil))
    15861506                      (when region
     
    16181538                   :<NSS>election<G>ranularity g))))))
    16191539
    1620 ;; Return nil to use the default Cocoa selection, which will be word for double-click, line for triple.
    1621 (defun selection-for-click (mark paragraph-mode-p)
    1622   ;; Handle lisp mode specially, otherwise just go with default Cocoa behavior
    1623   (when (string= (hi:buffer-major-mode (hi::mark-buffer mark)) "Lisp") ;; gag
    1624     (unless paragraph-mode-p
    1625       (let ((region (hemlock::word-region-at-mark mark)))
    1626         (when region
    1627           (return-from selection-for-click region))))
    1628     (hemlock::pre-command-parse-check mark)
    1629     (hemlock::form-region-at-mark mark)))
    1630 
    16311540(defun append-output (view string)
    16321541  (assume-cocoa-thread)
     
    16371546
    16381547
    1639 (defun move-point-for-click (buffer index)
    1640   (let* ((point (hi::buffer-point buffer))
    1641          (mark (and (hemlock::%buffer-region-active-p buffer) (hi::buffer-mark buffer))))
    1642     (setf (hi::buffer-region-active buffer) nil)
    1643     (unless (eql (hi:mark-absolute-position point) index)  ;; if point is already at target, leave mark alone
    1644       (if (and mark (eql (hi:mark-absolute-position mark) index))
    1645         (hi:move-mark mark point)
    1646         (hi::push-new-buffer-mark point))
    1647       (hi:move-to-absolute-position point index))))
    1648  
    16491548;;; Update the underlying buffer's point (and "active region", if appropriate.
    16501549;;; This is called in response to a mouse click or other event; it shouldn't
     
    16771576               (#_NSLog #@"Moving point to absolute position %d" :int location)
    16781577               ;; Do this even if still-selecting, in order to enable the heuristic below.
    1679                (move-point-for-click buffer location)
     1578               (hemlock:move-point-for-click buffer location)
    16801579               (update-paren-highlight self))
    16811580              (t
     
    21372036  +null-ptr+) ;For now, undo is not supported for echo-areas
    21382037
    2139 (defmethod update-buffer-package ((doc echo-area-document) buffer)
    2140   (declare (ignore buffer)))
     2038(defmethod update-buffer-package ((doc echo-area-document))
     2039  nil)
    21412040
    21422041(defmethod document-invalidate-modeline ((self echo-area-document))
     
    27602659           (#/setNeedsDisplay: (text-pane-mode-line pane) t))))))
    27612660
    2762 (defmethod update-buffer-package ((doc hemlock-editor-document) buffer)
    2763   (let* ((name (or (hemlock::package-at-mark (hi::buffer-point buffer))
    2764                    (hi::variable-value 'hemlock::default-package :buffer buffer))))
    2765     (when name
    2766       (let* ((pkg (find-package name)))
    2767         (if pkg
    2768           (setq name (shortest-package-name pkg))))
    2769       (let* ((curname (hi::variable-value 'hemlock::current-package :buffer buffer)))
    2770         (if (or (null curname)
    2771                 (not (string= curname name)))
    2772           (setf (hi::variable-value 'hemlock::current-package :buffer buffer) name))))))
     2661(defmethod update-buffer-package ((doc hemlock-editor-document))
     2662  (hemlock:update-current-package))
    27732663
    27742664(defun hemlock-ext:note-selection-set-by-search (buffer)
     
    37583648         (execute-in-gui #'(lambda () (find-or-make-hemlock-view arg))))
    37593649        ((ccl::valid-function-name-p arg)
    3760          (hemlock::edit-definition arg)
     3650         (hemlock:edit-definition arg)
    37613651         nil)
    37623652        (t (report-bad-arg arg '(or null string pathname (satisfies ccl::valid-function-name-p))))))
     
    37803670                     (error () nil)))))
    37813671    (if symbol
    3782       (hemlock::edit-definition symbol)
     3672      (hemlock:edit-definition symbol)
    37833673      (execute-in-gui #'(lambda ()
    37843674                          (find-or-make-hemlock-view
  • trunk/source/cocoa-ide/cocoa-listener.lisp

    r15291 r15906  
    369369  (hemlock-document-process (hi::buffer-document buffer)))
    370370
    371 (defmethod update-buffer-package ((doc hemlock-listener-document) buffer)
    372   (declare (ignore buffer)))
     371(defmethod update-buffer-package ((doc hemlock-listener-document))
     372  nil)
    373373
    374374(defmethod document-encoding-name ((doc hemlock-listener-document))
     
    685685  t)
    686686
    687 (defun shortest-package-name (package)
    688   (let* ((name (package-name package))
    689          (len (length name)))
    690     (dolist (nick (package-nicknames package) name)
    691       (let* ((nicklen (length nick)))
    692         (if (< nicklen len)
    693           (setq name nick len nicklen))))))
    694 
    695687(defmethod ui-object-note-package ((app ns:ns-application) package)
    696   (let ((proc *current-process*)
    697         (name (shortest-package-name package)))
     688  (let ((proc *current-process*))
    698689    (execute-in-gui #'(lambda ()
    699690                        (dolist (buf hi::*buffer-list*)
    700691                          (when (eq proc (buffer-process buf))
    701                             (setf (hi::variable-value 'hemlock::current-package :buffer buf) name)))))))
     692                            (let ((hi::*current-buffer* buf))
     693                              (hemlock:update-current-package package))))))))
    702694
    703695
  • trunk/source/cocoa-ide/compile-hemlock.lisp

    r15885 r15906  
    8989    "symbol-completion"
    9090    "bindings"
     91
     92    "display"
    9193    ))
    9294
  • trunk/source/cocoa-ide/hemlock/src/edit-defs.lisp

    r15880 r15906  
    4141                                       (region mark point)
    4242                                       (region point mark))))
    43       (symbol-at-mark buffer point))))
    44 
    45 (defun symbol-at-mark (buffer mark)
     43      (symbol-at-mark point))))
     44
     45(defun symbol-at-mark (mark)
    4646  (with-mark ((mark1 mark)
    4747              (mark2 mark))
  • trunk/source/cocoa-ide/hemlock/src/lispmode.lisp

    r15493 r15906  
    478478             (if info
    479479                 (dolist (range (lisp-info-ranges-to-ignore info)
     480                                ;; if mark is at end of line, should check ending-quoted so can quote the newline...
    480481                                (values nil line))
    481482                   (let ((start (car range))
     
    877878                 (when (test-char (next-character mark) :lisp-syntax :symbol-quote)
    878879                   (return t))
    879                  (character-offset mark 2))
     880                 (unless (character-offset mark 2)
     881                   (return nil)))
    880882         (return nil))
    881883       (mark-after mark))
    882884      (:char-quote
    883        (character-offset mark 2))
     885       (unless (character-offset mark 2)
     886         (return nil)))
    884887      (t (return mark)))))
    885888
     
    21982201    (new-search-pattern :string-insensitive :backward "in-package" nil))
    21992202
    2200 (defun package-at-mark (start-mark)
     2203(defun package-at-mark (start-mark &optional return-mark)
    22012204  (let* ((pattern *previous-in-package-search-pattern*)
    22022205         (mark (copy-mark start-mark :temporary)))
     
    22252228                                   'in-package)))
    22262229                   (go again))
    2227                  (unless (form-offset end 1) (format t "~& worse") (return 4))
     2230                 (unless (form-offset end 1) (go again))
    22282231                 (move-mark start end)
    2229                  (form-offset start -1)
     2232                 (unless (form-offset start -1) (go again))
    22302233                 (return
    22312234                  (if (eql (next-character start) #\")
     
    22332236                      (character-offset start 1)
    22342237                      (character-offset end -1)
     2238                      (when return-mark (move-mark return-mark list-end))
    22352239                      (region-to-string (region start end)))
    2236                     (let* ((pkgname (ignore-errors (values (read-from-string (region-to-string (region start end)))))))
    2237                       (if pkgname
    2238                         (values (ignore-errors (string pkgname)))))))))))
     2240                     (let* ((pkgname (ignore-errors (read-from-string (region-to-string (region start end))))))
     2241                       (when (and pkgname (setq pkgname (ignore-errors (string pkgname))))
     2242                         (when return-mark (move-mark return-mark list-end))
     2243                         pkgname))))))))
    22392244         again)))))
    22402245
  • trunk/source/cocoa-ide/hemlock/src/package.lisp

    r15886 r15906  
    395395   #:raise-buffer-view
    396396   #:string-to-clipboard
     397   #:lookup-color
    397398   ))
    398399
     
    622623(defpackage :hemlock
    623624  (:use :common-lisp :hemlock-interface :hemlock-internals :hemlock-ext)
    624   )
     625  (:export ;; Symbols defined in hemlock for use in the IDE
     626   #:with-display-context
     627   #:update-current-package
     628   #:paren-matching-bounds
     629   #:compute-syntax-coloring
     630   #:selection-for-click
     631   #:move-point-for-click
     632   #:edit-definition
     633   ))
    625634
    626635
  • trunk/source/cocoa-ide/hemlock/src/searchcoms.lisp

    r15881 r15906  
    508508  (let ((buffer (mark-buffer mark)))
    509509    (mark-after mark)
    510     (let ((str (symbol-at-mark buffer mark)))
     510    (let ((str (symbol-at-mark mark)))
    511511      (when str
    512512        (multiple-value-bind (sym error)
Note: See TracChangeset for help on using the changeset viewer.