sly-fontifying-fu.el (8308B)
1 ;; -*- lexical-binding: t; -*- 2 (require 'sly) 3 (require 'sly-parse "lib/sly-parse") 4 (require 'font-lock) 5 (require 'cl-lib) 6 7 ;;; Fontify WITH-FOO, DO-FOO, and DEFINE-FOO like standard macros. 8 ;;; Fontify CHECK-FOO like CHECK-TYPE. 9 (defvar sly-additional-font-lock-keywords 10 '(("(\\(\\(\\s_\\|\\w\\)*:\\(define-\\|do-\\|with-\\|without-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) 11 ("(\\(\\(define-\\|do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) 12 ("(\\(check-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face) 13 ("(\\(assert-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face))) 14 15 ;;;; Specially fontify forms suppressed by a reader conditional. 16 (defcustom sly-highlight-suppressed-forms t 17 "Display forms disabled by reader conditionals as comments." 18 :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil)) 19 :group 'sly-mode) 20 21 (define-sly-contrib sly-fontifying-fu 22 "Additional fontification tweaks: 23 Fontify WITH-FOO, DO-FOO, DEFINE-FOO like standard macros. 24 Fontify CHECK-FOO like CHECK-TYPE." 25 (:authors "Tobias C. Rittweiler <tcr@freebits.de>") 26 (:license "GPL") 27 (:on-load 28 (font-lock-add-keywords 29 'lisp-mode sly-additional-font-lock-keywords) 30 (when sly-highlight-suppressed-forms 31 (sly-activate-font-lock-magic))) 32 (:on-unload 33 ;; FIXME: remove `sly-search-suppressed-forms', and remove the 34 ;; extend-region hook. 35 (font-lock-remove-keywords 36 'lisp-mode sly-additional-font-lock-keywords))) 37 38 (defface sly-reader-conditional-face 39 '((t (:inherit font-lock-comment-face))) 40 "Face for compiler notes while selected." 41 :group 'sly-mode-faces) 42 43 (defvar sly-search-suppressed-forms-match-data (list nil nil)) 44 45 (defun sly-search-suppressed-forms-internal (limit) 46 (when (search-forward-regexp sly-reader-conditionals-regexp limit t) 47 (let ((start (match-beginning 0)) ; save match data 48 (state (sly-current-parser-state))) 49 (if (or (nth 3 state) (nth 4 state)) ; inside string or comment? 50 (sly-search-suppressed-forms-internal limit) 51 (let* ((char (char-before)) 52 (expr (read (current-buffer))) 53 (val (sly-eval-feature-expression expr))) 54 (when (<= (point) limit) 55 (if (or (and (eq char ?+) (not val)) 56 (and (eq char ?-) val)) 57 ;; If `sly-extend-region-for-font-lock' did not 58 ;; fully extend the region, the assertion below may 59 ;; fail. This should only happen on XEmacs and older 60 ;; versions of GNU Emacs. 61 (ignore-errors 62 (forward-sexp) (backward-sexp) 63 ;; Try to suppress as far as possible. 64 (sly-forward-sexp) 65 (cl-assert (<= (point) limit)) 66 (let ((md (match-data nil sly-search-suppressed-forms-match-data))) 67 (setf (cl-first md) start) 68 (setf (cl-second md) (point)) 69 (set-match-data md) 70 t)) 71 (sly-search-suppressed-forms-internal limit)))))))) 72 73 (defun sly-search-suppressed-forms (limit) 74 "Find reader conditionalized forms where the test is false." 75 (when (and sly-highlight-suppressed-forms 76 (sly-connected-p)) 77 (let ((result 'retry)) 78 (while (and (eq result 'retry) (<= (point) limit)) 79 (condition-case condition 80 (setq result (sly-search-suppressed-forms-internal limit)) 81 (end-of-file ; e.g. #+( 82 (setq result nil)) 83 ;; We found a reader conditional we couldn't process for 84 ;; some reason; however, there may still be other reader 85 ;; conditionals before `limit'. 86 (invalid-read-syntax ; e.g. #+#.foo 87 (setq result 'retry)) 88 (scan-error ; e.g. #+nil (foo ... 89 (setq result 'retry)) 90 (sly-incorrect-feature-expression ; e.g. #+(not foo bar) 91 (setq result 'retry)) 92 (sly-unknown-feature-expression ; e.g. #+(foo) 93 (setq result 'retry)) 94 (error 95 (setq result nil) 96 (sly-warning 97 (concat "Caught error during fontification while searching for forms\n" 98 "that are suppressed by reader-conditionals. The error was: %S.") 99 condition)))) 100 result))) 101 102 103 (defun sly-search-directly-preceding-reader-conditional () 104 "Search for a directly preceding reader conditional. Return its 105 position, or nil." 106 ;;; We search for a preceding reader conditional. Then we check that 107 ;;; between the reader conditional and the point where we started is 108 ;;; no other intervening sexp, and we check that the reader 109 ;;; conditional is at the same nesting level. 110 (condition-case nil 111 (let* ((orig-pt (point)) 112 (reader-conditional-pt 113 (search-backward-regexp sly-reader-conditionals-regexp 114 ;; We restrict the search to the 115 ;; beginning of the /previous/ defun. 116 (save-excursion 117 (beginning-of-defun) 118 (point)) 119 t))) 120 (when reader-conditional-pt 121 (let* ((parser-state 122 (parse-partial-sexp 123 (progn (goto-char (+ reader-conditional-pt 2)) 124 (forward-sexp) ; skip feature expr. 125 (point)) 126 orig-pt)) 127 (paren-depth (car parser-state)) 128 (last-sexp-pt (cl-caddr parser-state))) 129 (if (and paren-depth 130 (not (cl-plusp paren-depth)) ; no '(' in between? 131 (not last-sexp-pt)) ; no complete sexp in between? 132 reader-conditional-pt 133 nil)))) 134 (scan-error nil))) ; improper feature expression 135 136 137 ;;; We'll push this onto `font-lock-extend-region-functions'. In past, 138 ;;; we didn't do so which made our reader-conditional font-lock magic 139 ;;; pretty unreliable (it wouldn't highlight all suppressed forms, and 140 ;;; worked quite non-deterministic in general.) 141 ;;; 142 ;;; Cf. _Elisp Manual_, 23.6.10 Multiline Font Lock Constructs. 143 ;;; 144 ;;; We make sure that `font-lock-beg' and `font-lock-end' always point 145 ;;; to the beginning or end of a toplevel form. So we never miss a 146 ;;; reader-conditional, or point in mid of one. 147 (defvar font-lock-beg) ; shoosh compiler 148 (defvar font-lock-end) 149 150 (defun sly-extend-region-for-font-lock () 151 (when sly-highlight-suppressed-forms 152 (condition-case c 153 (let (changedp) 154 (cl-multiple-value-setq (changedp font-lock-beg font-lock-end) 155 (sly-compute-region-for-font-lock font-lock-beg font-lock-end)) 156 changedp) 157 (error 158 (sly-warning 159 (concat "Caught error when trying to extend the region for fontification.\n" 160 "The error was: %S\n" 161 "Further: font-lock-beg=%d, font-lock-end=%d.") 162 c font-lock-beg font-lock-end))))) 163 164 (defsubst sly-beginning-of-tlf () 165 (let ((pos (syntax-ppss-toplevel-pos (sly-current-parser-state)))) 166 (if pos (goto-char pos)))) 167 168 (defun sly-compute-region-for-font-lock (orig-beg orig-end) 169 (let ((beg orig-beg) 170 (end orig-end)) 171 (goto-char beg) 172 (sly-beginning-of-tlf) 173 (cl-assert (not (cl-plusp (nth 0 (sly-current-parser-state))))) 174 (setq beg (let ((pt (point))) 175 (cond ((> (- beg pt) 20000) beg) 176 ((sly-search-directly-preceding-reader-conditional)) 177 (t pt)))) 178 (goto-char end) 179 (while (search-backward-regexp sly-reader-conditionals-regexp beg t) 180 (setq end (max end (save-excursion 181 (ignore-errors (sly-forward-reader-conditional)) 182 (point))))) 183 (cl-values (or (/= beg orig-beg) (/= end orig-end)) beg end))) 184 185 186 (defun sly-activate-font-lock-magic () 187 (font-lock-add-keywords 188 'lisp-mode 189 `((sly-search-suppressed-forms 0 ,''sly-reader-conditional-face t))) 190 191 (add-hook 'lisp-mode-hook 192 #'(lambda () 193 (add-hook 'font-lock-extend-region-functions 194 'sly-extend-region-for-font-lock t t)))) 195 196 197 ;;; Compile hotspots 198 ;;; 199 (sly-byte-compile-hotspots 200 '(sly-extend-region-for-font-lock 201 sly-compute-region-for-font-lock 202 sly-search-directly-preceding-reader-conditional 203 sly-search-suppressed-forms 204 sly-beginning-of-tlf)) 205 206 (provide 'sly-fontifying-fu)