| [15906] | 1 | ;;;
|
|---|
| [16688] | 2 | ;;; Copyright 2013 Clozure Associates
|
|---|
| [15906] | 3 | ;;;
|
|---|
| [16688] | 4 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|---|
| 5 | ;;; you may not use this file except in compliance with the License.
|
|---|
| 6 | ;;; You may obtain a copy of the License at
|
|---|
| 7 | ;;;
|
|---|
| 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0
|
|---|
| 9 | ;;;
|
|---|
| 10 | ;;; Unless required by applicable law or agreed to in writing, software
|
|---|
| 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|---|
| 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|---|
| 13 | ;;; See the License for the specific language governing permissions and
|
|---|
| 14 | ;;; limitations under the License.
|
|---|
| [15906] | 15 |
|
|---|
| 16 | (in-package :hemlock)
|
|---|
| 17 |
|
|---|
| 18 | ;; Functions used by the IDE display code.
|
|---|
| 19 |
|
|---|
| [16343] | 20 | (defmacro with-display-context ((view &optional pane) &body body)
|
|---|
| 21 | (let ((viewvar (gensym "VIEW")))
|
|---|
| 22 | `(let* ((,viewvar ,view)
|
|---|
| 23 | (hi::*current-view* ,viewvar)
|
|---|
| 24 | (hi::*current-buffer* (ecase ,pane
|
|---|
| 25 | ((:text) (hi::hemlock-view-buffer ,viewvar))
|
|---|
| 26 | ((:echo) (hi::hemlock-echo-area-buffer ,viewvar))
|
|---|
| 27 | ((nil) (hi::hemlock-view-current-buffer ,viewvar)))))
|
|---|
| 28 | (hi::with-default-view-for-buffer (,viewvar)
|
|---|
| 29 | ,@body))))
|
|---|
| [15906] | 30 |
|
|---|
| 31 | ;; User variable. Maps symbol categories (see compute-symbol-category) to color specs
|
|---|
| 32 | (defvar *lisp-code-colors* '((:string :blue)
|
|---|
| 33 | (:comment :brown)
|
|---|
| 34 | (:double-comment :orange)
|
|---|
| 35 | (:triple-comment :red)
|
|---|
| 36 | (:system-symbol (0 .5 0 1))
|
|---|
| 37 | (:definition (1 0 1 1))
|
|---|
| [15931] | 38 | (:keyword :purple)
|
|---|
| [15966] | 39 | (:unmatched-paren :red)
|
|---|
| 40 | (:matched-paren (:background (0.3 0.875 0.8125 1)))))
|
|---|
| 41 |
|
|---|
| [15930] | 42 | ;; Cache for actual color objects.
|
|---|
| [15966] | 43 | (ccl:defloadvar *lisp-code-colors-cache* nil)
|
|---|
| [15906] | 44 |
|
|---|
| [15930] | 45 | ;; (cached-lisp-code-colors)
|
|---|
| 46 | (defun cached-lisp-code-colors ()
|
|---|
| 47 | (let ((specs (car *lisp-code-colors-cache*))
|
|---|
| 48 | (alist (cdr *lisp-code-colors-cache*))
|
|---|
| 49 | (user-alist *lisp-code-colors*))
|
|---|
| 50 | (flet ((get-spec (cell)
|
|---|
| 51 | (let ((spec (cdr cell)))
|
|---|
| 52 | (if (and (consp spec) (null (cdr spec)))
|
|---|
| 53 | (car spec)
|
|---|
| 54 | spec))))
|
|---|
| 55 | (declare (inline get-spec))
|
|---|
| 56 | (unless (and (eql (length user-alist) (length alist))
|
|---|
| 57 | (loop for spec in specs for cell in alist for user-cell in user-alist
|
|---|
| 58 | always (and (eq (car cell) (car user-cell)) (eq spec (get-spec user-cell)))))
|
|---|
| 59 | (setq specs (mapcar #'get-spec user-alist))
|
|---|
| 60 | (setq alist (mapcar #'(lambda (user-cell spec)
|
|---|
| [15966] | 61 | (cons (car user-cell)
|
|---|
| 62 | (if (and (consp spec) (keywordp (car spec)) (null (cddr spec)))
|
|---|
| 63 | (cons (car spec) (hemlock-ext:lookup-color (cadr spec)))
|
|---|
| 64 | (cons :foreground (hemlock-ext:lookup-color spec)))))
|
|---|
| [15930] | 65 | user-alist specs))
|
|---|
| 66 | (setq *lisp-code-colors-cache* (cons specs alist)))
|
|---|
| 67 | alist)))
|
|---|
| [15906] | 68 |
|
|---|
| [15966] | 69 | (defun hemlock:compute-paren-highlighting ()
|
|---|
| 70 | "Compute the positions of the characters to be shown as matching parens"
|
|---|
| 71 | (let* ((point (current-point))
|
|---|
| 72 | (color-alist (cached-lisp-code-colors))
|
|---|
| 73 | (color (cdr (assq :matched-paren color-alist))))
|
|---|
| 74 | (when color
|
|---|
| 75 | (cond ((test-char (next-character point) :lisp-syntax :open-paren)
|
|---|
| 76 | (pre-command-parse-check point)
|
|---|
| 77 | (when (valid-spot point t)
|
|---|
| 78 | (with-mark ((temp point))
|
|---|
| 79 | (when (list-offset temp 1)
|
|---|
| 80 | (list (cons (mark-absolute-position point) color)
|
|---|
| 81 | (cons (1- (mark-absolute-position temp)) color))))))
|
|---|
| 82 | ((test-char (previous-character point) :lisp-syntax :close-paren)
|
|---|
| 83 | (pre-command-parse-check point)
|
|---|
| 84 | (when (valid-spot point nil)
|
|---|
| [15906] | 85 | (with-mark ((temp point))
|
|---|
| 86 | (when (list-offset temp -1)
|
|---|
| [15966] | 87 | (list (cons (mark-absolute-position temp) color)
|
|---|
| 88 | (cons (1- (mark-absolute-position point)) color))))))))))
|
|---|
| [15906] | 89 |
|
|---|
| 90 |
|
|---|
| 91 | ;; Return nil to use the default Cocoa selection, which will be word for double-click, line for triple.
|
|---|
| 92 | (defun hemlock:selection-for-click (mark paragraph-mode-p)
|
|---|
| 93 | ;; Handle lisp mode specially, otherwise just go with default Cocoa behavior
|
|---|
| [16446] | 94 | (when (lisp-mode? mark)
|
|---|
| [15906] | 95 | (unless paragraph-mode-p
|
|---|
| 96 | (let ((region (word-region-at-mark mark)))
|
|---|
| 97 | (when region
|
|---|
| 98 | (return-from selection-for-click region))))
|
|---|
| 99 | (pre-command-parse-check mark)
|
|---|
| 100 | (form-region-at-mark mark)))
|
|---|
| 101 |
|
|---|
| 102 | (defun hemlock:move-point-for-click (buffer index)
|
|---|
| 103 | (let* ((point (buffer-point buffer))
|
|---|
| 104 | (mark (and (%buffer-region-active-p buffer) (buffer-mark buffer))))
|
|---|
| 105 | (setf (hi::buffer-region-active buffer) nil)
|
|---|
| 106 | (unless (eql (mark-absolute-position point) index) ;; if point is already at target, leave mark alone
|
|---|
| 107 | (if (and mark (eql (mark-absolute-position mark) index))
|
|---|
| 108 | (move-mark mark point)
|
|---|
| 109 | (push-new-buffer-mark point))
|
|---|
| 110 | (move-to-absolute-position point index))))
|
|---|
| 111 |
|
|---|
| 112 |
|
|---|
| 113 | (defun shortest-package-name (package)
|
|---|
| 114 | (let* ((name (package-name package))
|
|---|
| 115 | (len (length name)))
|
|---|
| 116 | (dolist (nick (package-nicknames package) name)
|
|---|
| 117 | (let* ((nicklen (length nick)))
|
|---|
| 118 | (if (< nicklen len)
|
|---|
| 119 | (setq name nick len nicklen))))))
|
|---|
| 120 |
|
|---|
| [15926] | 121 | (defun hemlock:update-current-package (&optional pkg (buffer (current-buffer)))
|
|---|
| [16446] | 122 | (when (lisp-mode? buffer)
|
|---|
| [15906] | 123 | (unless pkg
|
|---|
| 124 | (setq pkg (or (package-at-mark (current-point))
|
|---|
| [15926] | 125 | (variable-value 'default-package :buffer buffer))))
|
|---|
| [15906] | 126 | (when pkg
|
|---|
| 127 | (let* ((name (if (packagep pkg) (package-name pkg) (string pkg)))
|
|---|
| [15926] | 128 | (curname (variable-value 'current-package :buffer buffer)))
|
|---|
| [15906] | 129 | (when (setq pkg (find-package name))
|
|---|
| 130 | (setq name (shortest-package-name pkg)))
|
|---|
| 131 | (if (or (null curname)
|
|---|
| 132 | (not (string= curname name)))
|
|---|
| [15926] | 133 | (setf (variable-value 'current-package :buffer buffer) name))))))
|
|---|
| [15906] | 134 |
|
|---|
| 135 | ;; advance to next symbol, ignoring form boundaries, strings, etc.
|
|---|
| 136 | (defun %scan-to-symbol (mark)
|
|---|
| 137 | (loop while (%scan-to-form mark t)
|
|---|
| 138 | do (unless (test-char (next-character mark) :lisp-syntax (or :string-quote :open-paren :close-paren))
|
|---|
| 139 | (return mark))
|
|---|
| 140 | do (mark-after mark)))
|
|---|
| 141 |
|
|---|
| 142 | ;; Advance to next atom, ignoring open parens (but not close parens, unlike above).
|
|---|
| 143 | (defun %scan-down-to-atom (mark)
|
|---|
| 144 | (loop while (%scan-to-form mark t)
|
|---|
| 145 | do (unless (test-char (next-character mark) :lisp-syntax :open-paren)
|
|---|
| 146 | (return mark))
|
|---|
| 147 | do (mark-after mark)))
|
|---|
| 148 |
|
|---|
| 149 | #+debug
|
|---|
| 150 | (defun buffer-short-name ()
|
|---|
| 151 | (let* ((full-name (buffer-name (current-buffer)))
|
|---|
| 152 | (pos (position #\space full-name)))
|
|---|
| 153 | (if pos (subseq full-name 0 pos) full-name)))
|
|---|
| 154 |
|
|---|
| 155 | ;; When get a cache miss, means we'll fill in parsing and line-origin caches for the whole buffer, so might
|
|---|
| 156 | ;; as well get a little extra coloring pre-computed in as well, for smoother scrolling...
|
|---|
| 157 | (defparameter $coloring-cache-extra 1000)
|
|---|
| 158 |
|
|---|
| 159 | (defstruct coloring-cache
|
|---|
| 160 | (tick nil)
|
|---|
| 161 | (start 0)
|
|---|
| 162 | (end 0)
|
|---|
| [15930] | 163 | (colors nil)
|
|---|
| [15906] | 164 | (data nil))
|
|---|
| 165 |
|
|---|
| 166 | (defun make-sym-vec ()
|
|---|
| 167 | (make-array 0 :displaced-to "" :adjustable t))
|
|---|
| 168 |
|
|---|
| 169 | (defun displace-to-region (sym-vec start-mark end-mark)
|
|---|
| 170 | (let* ((sym-line (mark-line start-mark))
|
|---|
| 171 | (line-str (line-string sym-line))
|
|---|
| 172 | (start-pos (mark-charpos start-mark))
|
|---|
| 173 | (end-pos (if (eq sym-line (mark-line end-mark))
|
|---|
| 174 | (mark-charpos end-mark)
|
|---|
| 175 | (progn
|
|---|
| 176 | (setq line-str (region-to-string (region start-mark end-mark)))
|
|---|
| 177 | (setq start-pos 0)
|
|---|
| 178 | (length line-str)))))
|
|---|
| 179 | (ccl::%displace-array sym-vec nil (- end-pos start-pos) line-str start-pos T)))
|
|---|
| 180 |
|
|---|
| 181 | #+debug
|
|---|
| 182 | (defmethod print-object ((cache coloring-cache) stream)
|
|---|
| 183 | (print-unreadable-object (stream cache :identity nil :type t)
|
|---|
| 184 | (format stream "~s:~s @~s" (coloring-cache-start cache) (coloring-cache-end cache) (coloring-cache-tick cache))))
|
|---|
| 185 |
|
|---|
| 186 | (defun hemlock:compute-syntax-coloring (start-pos length)
|
|---|
| 187 | (let* ((buffer (current-buffer))
|
|---|
| 188 | (end-pos (+ start-pos length))
|
|---|
| 189 | (tick (buffer-signature buffer))
|
|---|
| [15930] | 190 | (colors (cached-lisp-code-colors))
|
|---|
| [15906] | 191 | (cache (or (getf (buffer-plist buffer) 'coloring-cache)
|
|---|
| 192 | (setf (getf (buffer-plist buffer) 'coloring-cache) (make-coloring-cache)))))
|
|---|
| 193 | (unless (and (eql (coloring-cache-tick cache) tick)
|
|---|
| 194 | (<= (coloring-cache-start cache) start-pos)
|
|---|
| 195 | (<= end-pos (coloring-cache-end cache))
|
|---|
| [15930] | 196 | (eq colors (coloring-cache-colors cache)))
|
|---|
| [15906] | 197 | (setq start-pos (max 0 (- start-pos $coloring-cache-extra)))
|
|---|
| 198 | (setq end-pos (+ end-pos $coloring-cache-extra))
|
|---|
| 199 | (let ((res (compute-syntax-coloring-in-region buffer start-pos end-pos)))
|
|---|
| 200 | (setf (coloring-cache-start cache) start-pos
|
|---|
| 201 | (coloring-cache-end cache) end-pos
|
|---|
| [15930] | 202 | (coloring-cache-colors cache) colors
|
|---|
| [15906] | 203 | (coloring-cache-data cache) res
|
|---|
| 204 | (coloring-cache-tick cache) tick)))
|
|---|
| 205 | (coloring-cache-data cache)))
|
|---|
| 206 |
|
|---|
| 207 | (defun case-insensitive-string-to-symbol (string pkg)
|
|---|
| 208 | (when (null pkg) (setq pkg *package*))
|
|---|
| [16485] | 209 | (let* ((str (coerce string 'simple-string)))
|
|---|
| 210 | (ignore-errors
|
|---|
| 211 | (case (readtable-case *readtable*)
|
|---|
| 212 | (:upcase (find-symbol (nstring-upcase str) pkg))
|
|---|
| 213 | (:downcase (find-symbol (nstring-downcase str) pkg))
|
|---|
| 214 | (:preserve (find-symbol str pkg))
|
|---|
| 215 | (t (find-symbol (nstring-upcase str) pkg)
|
|---|
| 216 | ; not the right way to handle :invert. Do we care?
|
|---|
| 217 | )))))
|
|---|
| [15906] | 218 |
|
|---|
| 219 | ;; Try to exclude use of symbol in data.
|
|---|
| 220 | (defun mark-at-invocation-p (start-mark)
|
|---|
| 221 | (and (test-char (previous-character start-mark) :lisp-syntax :open-paren)
|
|---|
| 222 | (prog2
|
|---|
| 223 | (mark-before start-mark)
|
|---|
| [15930] | 224 | (not (test-char (previous-character start-mark) :lisp-syntax (or :prefix :open-paren)))
|
|---|
| [15906] | 225 | (mark-after start-mark))))
|
|---|
| 226 |
|
|---|
| 227 | (defun compute-symbol-category (start-mark sym)
|
|---|
| 228 | (when (ccl::non-nil-symbol-p sym)
|
|---|
| 229 | (cond ((and (or (macro-function sym)
|
|---|
| 230 | (ccl::special-form-p sym))
|
|---|
| 231 | (mark-at-invocation-p start-mark))
|
|---|
| 232 | :system-symbol)
|
|---|
| 233 | ((keywordp sym)
|
|---|
| 234 | :keyword)
|
|---|
| 235 | (t nil))))
|
|---|
| 236 |
|
|---|
| 237 | (defvar *defining-symbols*
|
|---|
| 238 | '(defun defgeneric defmethod defmacro
|
|---|
| 239 | define-compiler-macro define-modify-macro define-symbol-macro
|
|---|
| 240 | define-setf-expander defsetf
|
|---|
| 241 | defvar defparameter defconstant
|
|---|
| 242 | define-method-combination
|
|---|
| 243 | defclass defstruct deftype define-condition
|
|---|
| 244 | defpackage
|
|---|
| 245 | ccl:advise
|
|---|
| 246 | ccl:def-load-pointers
|
|---|
| 247 | ccl:define-definition-type
|
|---|
| 248 | ccl:defloadvar
|
|---|
| 249 | ccl:defglobal ccl:defstaticvar ccl:define-declaration ccl:defstatic ccl:defcallback ccl:define-setf-method
|
|---|
| 250 | ccl:define-character-encoding
|
|---|
| 251 | ccl:defglobal
|
|---|
| 252 | hemlock-interface:defcommand
|
|---|
| 253 | hemlock-interface:define-file-option
|
|---|
| 254 | hemlock-interface:define-file-type-hook
|
|---|
| 255 | hemlock-interface:define-keysym-code
|
|---|
| 256 | gui::def-cocoa-default
|
|---|
| 257 | objc:define-objc-class-method
|
|---|
| 258 | objc:define-objc-method
|
|---|
| 259 | objc:defmethod))
|
|---|
| 260 |
|
|---|
| 261 | ;; If true, the next atom following this sym will be automatically categorized as :definition, without going through compute-symbol-category.
|
|---|
| 262 | (defun defining-symbol-p (start-mark sym)
|
|---|
| 263 | (and (mark-at-invocation-p start-mark)
|
|---|
| 264 | (or (member sym *defining-symbols*) ;; recognize these even if indented or embedded.
|
|---|
| 265 | (and (eql (mark-charpos start-mark) 1) ;; but accept any toplevel "(def".
|
|---|
| 266 | (or (let ((str (string sym)))
|
|---|
| 267 | (and (> (length str) 3) (string-equal "def" str :end2 3)))
|
|---|
| 268 | ;; color top-level setq's, just for fun
|
|---|
| 269 | (eq sym 'setq))))))
|
|---|
| 270 |
|
|---|
| 271 | (defun compute-string/comment-coloring-in-region (region-start region-end)
|
|---|
| [16446] | 272 | (when (lisp-mode? region-start)
|
|---|
| 273 | (let* ((lisp-code-colors (cached-lisp-code-colors))
|
|---|
| 274 | (start-line (mark-line region-start))
|
|---|
| 275 | (end-line (line-next (mark-line region-end)))
|
|---|
| 276 | (start-charpos (mark-charpos region-start)))
|
|---|
| 277 | (assert (not (eq start-line end-line)))
|
|---|
| 278 | (loop
|
|---|
| 279 | for line = start-line then (line-next line) until (eq line end-line)
|
|---|
| 280 | for info = (getf (line-plist line) 'lisp-info)
|
|---|
| 281 | when info
|
|---|
| 282 | nconc (loop with origin = (hi::line-origin line)
|
|---|
| 283 | for last-end = 0 then end-offset
|
|---|
| 284 | for (start-offset . end-offset) in (lisp-info-ranges-to-ignore info)
|
|---|
| 285 | for syntax = (if (eql start-offset 0)
|
|---|
| 286 | (lisp-info-begins-quoted info)
|
|---|
| 287 | (if (< last-end start-offset)
|
|---|
| 288 | (character-attribute :lisp-syntax (line-character line (1- start-offset)))
|
|---|
| 289 | :comment))
|
|---|
| 290 | do (when (member syntax '(:symbol-quote :string-quote))
|
|---|
| 291 | (when (< 0 start-offset)
|
|---|
| 292 | (decf start-offset))
|
|---|
| 293 | (when (< end-offset (line-length line))
|
|---|
| 294 | (incf end-offset)))
|
|---|
| 295 | unless (and (eq line start-line) (<= end-offset start-charpos))
|
|---|
| 296 | nconc (let* ((type (case syntax
|
|---|
| 297 | ((:char-quote :symbol-quote) nil)
|
|---|
| 298 | (:string-quote :string)
|
|---|
| 299 | (t (loop for i from start-offset as nsemi upfrom 0
|
|---|
| 300 | until (or (eql nsemi 3)
|
|---|
| 301 | (eql i end-offset)
|
|---|
| 302 | (not (test-char (line-character line i) :lisp-syntax :comment)))
|
|---|
| 303 | finally (return (case nsemi
|
|---|
| 304 | (2 :double-comment)
|
|---|
| 305 | (3 :triple-comment)
|
|---|
| 306 | (t :comment)))))))
|
|---|
| 307 | (color (and type (cdr (assq type lisp-code-colors)))))
|
|---|
| 308 | (when color
|
|---|
| 309 | (list (list* (+ origin start-offset) (- end-offset start-offset) color)))))))))
|
|---|
| [15906] | 310 |
|
|---|
| 311 | (defun coloring-region (start-mark end-mark color)
|
|---|
| 312 | (when color
|
|---|
| 313 | (let* ((start (mark-absolute-position start-mark))
|
|---|
| 314 | (end (mark-absolute-position end-mark))
|
|---|
| 315 | (len (- end start)))
|
|---|
| 316 | (when (> len 0)
|
|---|
| 317 | (list* start len color)))))
|
|---|
| 318 |
|
|---|
| 319 | (defun compute-symbol-coloring-in-region (region-start region-end)
|
|---|
| [16446] | 320 | (when (lisp-mode? region-start)
|
|---|
| 321 | (let* ((sym-vec (make-sym-vec))
|
|---|
| 322 | (pkg nil)
|
|---|
| 323 | (lisp-colors (cached-lisp-code-colors))
|
|---|
| 324 | (defn-color (cdr (assq :definition lisp-colors))))
|
|---|
| 325 | (with-mark ((start-mark region-start)
|
|---|
| 326 | (end-mark region-start))
|
|---|
| 327 | (let ((pkgname (package-at-mark region-end end-mark)))
|
|---|
| 328 | (when pkgname
|
|---|
| 329 | (when (mark< region-start end-mark)
|
|---|
| 330 | ;; Argh, more than one package in region. KLUDGE!!
|
|---|
| 331 | (return-from compute-symbol-coloring-in-region
|
|---|
| 332 | (nconc (compute-symbol-coloring-in-region region-start (mark-before end-mark))
|
|---|
| 333 | (compute-symbol-coloring-in-region (mark-after end-mark) region-end))))
|
|---|
| 334 | (setq pkg (find-package pkgname))))
|
|---|
| 335 | (loop
|
|---|
| 336 | while (and (%scan-to-symbol start-mark) (mark< start-mark region-end))
|
|---|
| 337 | for sym = (progn
|
|---|
| 338 | (move-mark end-mark start-mark)
|
|---|
| 339 | (unless (forward-form end-mark) (move-mark end-mark region-end))
|
|---|
| 340 | (case-insensitive-string-to-symbol (displace-to-region sym-vec start-mark end-mark) pkg))
|
|---|
| 341 | for type = (compute-symbol-category start-mark sym)
|
|---|
| 342 | for reg = (when type
|
|---|
| 343 | (let ((color (cdr (assq type lisp-colors))))
|
|---|
| 344 | (when color
|
|---|
| 345 | (coloring-region start-mark end-mark color))))
|
|---|
| 346 | when reg collect reg
|
|---|
| 347 | ;; if we're at start of a defining form, color the thing being defined.
|
|---|
| 348 | when (and defn-color
|
|---|
| 349 | (defining-symbol-p start-mark sym)
|
|---|
| 350 | (form-offset (move-mark start-mark end-mark) 1)
|
|---|
| 351 | (%scan-down-to-atom end-mark)
|
|---|
| 352 | (mark< end-mark region-end))
|
|---|
| 353 | collect (progn
|
|---|
| 354 | (move-mark start-mark end-mark)
|
|---|
| 355 | (unless (and (forward-form end-mark)
|
|---|
| 356 | (mark<= end-mark region-end))
|
|---|
| 357 | (move-mark end-mark region-end))
|
|---|
| 358 | (unless (mark< start-mark end-mark)
|
|---|
| 359 | (warn "definition got start ~s end ~s region-end ~s" start-mark end-mark
|
|---|
| 360 | region-end)
|
|---|
| 361 | (move-mark end-mark start-mark))
|
|---|
| 362 | (coloring-region start-mark end-mark defn-color))
|
|---|
| 363 | do (rotatef start-mark end-mark))))))
|
|---|
| [15906] | 364 |
|
|---|
| [15931] | 365 | (defun compute-unmatched-parens-coloring-in-region (start-mark end-mark)
|
|---|
| [16446] | 366 | ; not checking for lisp mode here because this is still useful even in text mode
|
|---|
| [15931] | 367 | (macrolet ((scan-loop (forwardp open-key buffer-start-mark start-line end-line close-key)
|
|---|
| 368 | `(loop with paren-count = 0 with limit-line = (neighbor-line ,end-line ,forwardp) with in-region-p = nil
|
|---|
| 369 | for line = (mark-line (,buffer-start-mark (mark-buffer m))) then (neighbor-line line ,forwardp)
|
|---|
| 370 | until (eq line limit-line)
|
|---|
| 371 | for info = (or (getf (line-plist line) 'lisp-info) (return nil))
|
|---|
| 372 | as parens-on-line = ,(if forwardp '(lisp-info-net-close-parens info) '(lisp-info-net-open-parens info))
|
|---|
| 373 | do (when (eq line ,start-line) (setq in-region-p t))
|
|---|
| 374 | do (decf paren-count parens-on-line)
|
|---|
| 375 | do (when (< paren-count 0)
|
|---|
| 376 | (when in-region-p
|
|---|
| 377 | ,(if forwardp '(line-start m line) '(line-end m line))
|
|---|
| 378 | (loop with net-count = (+ paren-count parens-on-line) doing
|
|---|
| 379 | (unless (scan-direction-valid m ,forwardp :lisp-syntax (or :close-paren :open-paren :newline))
|
|---|
| 380 | (error "couldn't find ~s mismatches" (- paren-count)))
|
|---|
| 381 | (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp))
|
|---|
| 382 | (,open-key (incf net-count))
|
|---|
| 383 | (,close-key (when (< (decf net-count) 0)
|
|---|
| 384 | (push (cons ,(if forwardp
|
|---|
| 385 | '(mark-absolute-position m)
|
|---|
| 386 | '(1- (mark-absolute-position m)))
|
|---|
| 387 | coloring-data) result)
|
|---|
| 388 | (when (eql (incf paren-count) 0) (return))
|
|---|
| 389 | (setq net-count 0))))
|
|---|
| 390 | (neighbor-mark m ,forwardp)))
|
|---|
| 391 | (setq paren-count 0))
|
|---|
| 392 | do (incf paren-count ,(if forwardp '(lisp-info-net-open-parens info) '(lisp-info-net-close-parens info))))))
|
|---|
| 393 | (with-mark ((m start-mark))
|
|---|
| 394 | (let* ((end-line (mark-line end-mark))
|
|---|
| 395 | (start-line (mark-line start-mark))
|
|---|
| 396 | (color (or (cdr (assq :unmatched-paren (cached-lisp-code-colors)))
|
|---|
| 397 | (return-from compute-unmatched-parens-coloring-in-region nil)))
|
|---|
| 398 | (coloring-data (cons 1 color))
|
|---|
| 399 | (result nil))
|
|---|
| 400 | (scan-loop t :open-paren buffer-start-mark start-line end-line :close-paren) ; Compute unmatched close parens, top down.
|
|---|
| 401 | (scan-loop nil :close-paren buffer-end-mark end-line start-line :open-paren) ; Compute umatched open parens, bottom up.
|
|---|
| 402 | result))))
|
|---|
| 403 |
|
|---|
| [15906] | 404 | (defun compute-syntax-coloring-in-region (buffer start-pos end-pos)
|
|---|
| 405 | (let* ((some-mark (buffer-point buffer)))
|
|---|
| 406 | (with-mark ((start-mark some-mark)
|
|---|
| 407 | (end-mark some-mark))
|
|---|
| 408 | (unless (move-to-absolute-position start-mark start-pos)
|
|---|
| 409 | (buffer-end start-mark))
|
|---|
| 410 | (unless (move-to-absolute-position end-mark end-pos)
|
|---|
| 411 | (buffer-end end-mark))
|
|---|
| 412 | (assert (mark<= start-mark end-mark))
|
|---|
| 413 | (when (mark< start-mark end-mark)
|
|---|
| 414 | (pre-command-parse-check start-mark)
|
|---|
| 415 | (sort (nconc (compute-string/comment-coloring-in-region start-mark end-mark)
|
|---|
| [15931] | 416 | (compute-symbol-coloring-in-region start-mark end-mark)
|
|---|
| 417 | (compute-unmatched-parens-coloring-in-region start-mark end-mark))
|
|---|
| [15906] | 418 | #'< :key #'car)))))
|
|---|
| 419 |
|
|---|
