├── .gitignore ├── Readme.org ├── highlight-stages.el ├── screenshot.png ├── screenshot2.png └── screenshot3.png /.gitignore: -------------------------------------------------------------------------------- 1 | *.elc 2 | 3 | -------------------------------------------------------------------------------- /Readme.org: -------------------------------------------------------------------------------- 1 | * highlight-stages.el 2 | 3 | 準クォートをハイライト 4 | 5 | Highlight staged (quasi-quoted) expressions. 6 | 7 | ** Screenshot 8 | *** Lisp. 9 | 10 | [[screenshot.png]] 11 | 12 | We can easily recognize what are evaluated now and what are quoted for 13 | later evaluation. 14 | 15 | *** MetaOCaml. 16 | 17 | [[screenshot2.png]] 18 | 19 | *** C/C++ 20 | 21 | [[screenshot3.png]] 22 | 23 | ** Installation 24 | 25 | Require this script 26 | 27 | : (require 'highlight-stages) 28 | 29 | and call function "highlight-stages-mode" 30 | 31 | : (add-hook 'emacs-lisp-mode-hook 'highlight-stages-mode) 32 | 33 | If you want to enable "highlight-stages-mode" (almost) everywhere, 34 | call "highlight-stages-global-mode" instead. 35 | 36 | : (highlight-stages-global-mode 1) 37 | 38 | ** Supported Languages 39 | 40 | Lisp-like languages, MetaOCaml, and C/C++ preprocessors. 41 | 42 | ** Customizations 43 | 44 | 5 faces 45 | 46 | - =highlight-stages-negative-level-face= 47 | - =highlight-stages-level-1-face= 48 | - =highlight-stages-level-2-face= 49 | - =highlight-stages-level-3-face= 50 | - =highlight-stages-higher-level-face= 51 | 52 | are all customizable. 53 | 54 | When =highlight-stages-highlight-real-quote= is non-nil, not only 55 | quasi-quotes(`) but also "real" quotes(') are highlighted. 56 | -------------------------------------------------------------------------------- /highlight-stages.el: -------------------------------------------------------------------------------- 1 | ;;; -*- lexical-binding: t -*- 2 | ;;; highlight-stages.el --- highlight staged (quasi-quoted) expressions 3 | 4 | ;; Copyright (C) 2014-2015 zk_phi 5 | 6 | ;; This program is free software; you can redistribute it and/or modify 7 | ;; it under the terms of the GNU General Public License as published by 8 | ;; the Free Software Foundation; either version 2 of the License, or 9 | ;; (at your option) any later version. 10 | ;; 11 | ;; This program is distributed in the hope that it will be useful, 12 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;; GNU General Public License for more details. 15 | ;; 16 | ;; You should have received a copy of the GNU General Public License 17 | ;; along with this program; if not, write to the Free Software 18 | ;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 19 | 20 | ;; Author: zk_phi 21 | ;; URL: http://hins11.yu-yake.com/ 22 | ;; Version: 1.1.0 23 | 24 | ;;; Commentary: 25 | 26 | ;; Require this script and call function "highlight-stages-global-mode" 27 | ;; 28 | ;; (require 'highlight-stages) 29 | ;; (highlight-stages-global-mode 1) 30 | 31 | ;; For more informations, see Readme. 32 | 33 | ;;; Change Log: 34 | 35 | ;; 1.0.0 first released 36 | ;; 1.0.1 turned into minor-mode 37 | ;; 1.0.2 add MetaOCaml support 38 | ;; 1.0.3 use faces instead of calculating background colors 39 | ;; 1.1.0 C/C++ preprocessor support 40 | 41 | ;;; Code: 42 | 43 | (require 'cl-lib) 44 | 45 | (defconst highlight-stages-version "1.1.0") 46 | 47 | ;; + customs 48 | 49 | (defgroup highlight-stages nil 50 | "Highlight staged (quasi-quoted) expressions" 51 | :group 'emacs) 52 | 53 | (defcustom highlight-stages-matcher-alist 54 | '((lisp-mode 55 | highlight-stages-lisp-quote-matcher . highlight-stages-lisp-escape-matcher) 56 | (emacs-lisp-mode 57 | highlight-stages-lisp-quote-matcher . highlight-stages-lisp-escape-matcher) 58 | (lisp-interaction-mode 59 | highlight-stages-lisp-quote-matcher . highlight-stages-lisp-escape-matcher) 60 | (scheme-mode 61 | highlight-stages-lisp-quote-matcher . highlight-stages-lisp-escape-matcher) 62 | (gauche-mode 63 | highlight-stages-lisp-quote-matcher . highlight-stages-lisp-escape-matcher) 64 | (racket-mode 65 | highlight-stages-lisp-quote-matcher . highlight-stages-lisp-escape-matcher) 66 | (clojure-mode 67 | highlight-stages-lisp-quote-matcher . highlight-stages-clojure-escape-matcher) 68 | (ocaml-mode 69 | highlight-stages-metaocaml-quote-matcher . highlight-stages-metaocaml-matcher-escape) 70 | (tuareg-mode 71 | highlight-stages-metaocaml-quote-matcher . highlight-stages-metaocaml-escape-matcher) 72 | (c-mode 73 | highlight-stages-c-preprocessor-matcher . nil) 74 | (c++-mode 75 | highlight-stages-c-preprocessor-matcher . nil) 76 | (objc-mode 77 | highlight-stages-c-preprocessor-matcher . nil)) 78 | "List of (MAJOR-MODE . (QUOTE-MATCHER . [ESCAPE-MATCHER])). 79 | 80 | QUOTE-MATCHER is a function with 1 parameter, LIMIT, which 81 | searches the next quoted expression. The function must return 82 | non-nil if succeeded, or nil otherwise. A special value 'real 83 | also can be returned by the function, when the quote is 84 | \"real\" (not escapable) quote. This may be useful for lisp-like 85 | languages. When the function returns non-nil, (match-string 0) 86 | must be the expression matched. 87 | 88 | ESCAPE-MATCHER is a function with 1 parameter, LIMIT, which 89 | searches the next escaped expression. The function must return 90 | non-nil if succeeded, or nil otherwise. When the function returns 91 | non-nil, (match-string 0) must be the expression matched." 92 | :type 'alist 93 | :group 'highlight-stages) 94 | 95 | (defcustom highlight-stages-highlight-real-quote t 96 | "If non-nil, \"real\" (not escapable) quotes are also 97 | highlighted." 98 | :type 'boolean 99 | :group 'highlight-stages) 100 | 101 | (defcustom highlight-stages-highlight-priority 1 102 | "Priority which highlight overlays get." 103 | :type 'integer 104 | :group 'highlight-stages) 105 | 106 | ;; + faces 107 | 108 | (defface highlight-stages-negative-level-face 109 | '((((background light)) (:background "#fefaf1")) 110 | (t (:background "#003745"))) 111 | "Face used to highlight staged expressions.") 112 | 113 | (defface highlight-stages-level-1-face 114 | '((((background light)) (:background "#fbf1d4")) 115 | (t (:background "#001e26"))) 116 | "Face used to highlight staged expressions.") 117 | 118 | (defface highlight-stages-level-2-face 119 | '((((background light)) (:background "#faecc6")) 120 | (t (:background "#001217"))) 121 | "Face used to highlight staged expressions.") 122 | 123 | (defface highlight-stages-level-3-face 124 | '((((background light)) (:background "#f9e8b8")) 125 | (t (:background "#000608"))) 126 | "Face used to highlight staged expressions.") 127 | 128 | (defface highlight-stages-higher-level-face 129 | '((((background light)) (:background "#f8e3a9")) 130 | (t (:background "#000000"))) 131 | "Face used to highlight staged expressions.") 132 | 133 | ;; + utils 134 | 135 | (defun highlight-stages--face (level) 136 | "Choose a face for LEVEL." 137 | (cond ((< level 0) 'highlight-stages-negative-level-face) 138 | ((= level 1) 'highlight-stages-level-1-face) 139 | ((= level 2) 'highlight-stages-level-2-face) 140 | ((= level 3) 'highlight-stages-level-3-face) 141 | ((> level 3) 'highlight-stages-higher-level-face))) 142 | 143 | (defun highlight-stages--make-overlay (beg end level) 144 | "Make a overlay. Trims existing overlays if necessary." 145 | ;; split or delete old overlay 146 | (dolist (ov (overlays-in beg end)) 147 | (when (eq (overlay-get ov 'category) 'highlight-stages) 148 | (let ((ov-beg (overlay-start ov)) 149 | (ov-end (overlay-end ov))) 150 | (cond ((and (< ov-beg beg) (< end ov-end)) 151 | (move-overlay ov ov-beg beg) 152 | (move-overlay (copy-overlay ov) end ov-end)) 153 | ((< ov-beg beg) 154 | (move-overlay ov ov-beg beg)) 155 | ((< end ov-beg) 156 | (move-overlay ov end ov-end)) 157 | (t 158 | (delete-overlay ov)))))) 159 | ;; we don't need to make an overlay if (level = 0) 160 | (unless (zerop level) 161 | (let ((ov (make-overlay beg end))) 162 | (overlay-put ov 'face (highlight-stages--face level)) 163 | (overlay-put ov 'category 'highlight-stages) 164 | (overlay-put ov 'priority highlight-stages-highlight-priority)))) 165 | 166 | (defun highlight-stages--search-forward-regexp (regexp &optional limit) 167 | "Like (search-forward-regexp REGEXP LIMIT t) but skips comments 168 | and strings." 169 | (let ((original-pos (point)) syntax) 170 | (catch 'found 171 | (while (search-forward-regexp regexp limit t) 172 | (setq syntax (save-match-data (syntax-ppss))) 173 | (when (and (not (nth 3 syntax)) 174 | (not (nth 4 syntax))) 175 | (throw 'found (point)))) 176 | (goto-char original-pos) 177 | nil))) 178 | 179 | ;; + the jit highlighter 180 | 181 | (defun highlight-stages-jit-highlighter (beg end) 182 | "The jit highlighter of highlight-stages." 183 | (setq beg (progn (goto-char beg) 184 | (beginning-of-defun) 185 | (skip-syntax-backward "'-") ; skip newlines? 186 | (point)) 187 | end (progn (goto-char end) 188 | (end-of-defun) 189 | (skip-syntax-forward "'-") ; skip newlines? 190 | (point))) 191 | (remove-overlays beg end 'category 'highlight-stages) 192 | (highlight-stages--jit-highlighter-1 beg end 0)) 193 | 194 | (defun highlight-stages--jit-highlighter-1 (beg end base-level) 195 | "Scan and highlight this level." 196 | (highlight-stages--make-overlay beg end base-level) 197 | (goto-char beg) 198 | (let* ((pair (assq major-mode highlight-stages-matcher-alist)) 199 | (quote-matcher (cadr pair)) 200 | (escape-matcher (cddr pair)) 201 | quote escape) 202 | (when quote-matcher 203 | (while (progn 204 | (setq quote (save-excursion 205 | ;; 'real means "real" (non-"quasi") quote 206 | (let ((res (funcall quote-matcher end))) 207 | (cond ((eq res 'real) 208 | (cons (match-beginning 0) (cons (match-end 0) t))) 209 | (res 210 | (list (match-beginning 0) (match-end 0)))))) 211 | escape (save-excursion 212 | (when (and escape-matcher (funcall escape-matcher end)) 213 | (list (match-beginning 0) (match-end 0))))) 214 | (or quote escape)) 215 | (cond ((or (null escape) 216 | (and quote (< (car quote) (car escape)))) 217 | (save-excursion 218 | (cond ((not (cddr quote)) 219 | ;; "quasi"-quote -> a staging operator (increment level) 220 | (highlight-stages--jit-highlighter-1 221 | (car quote) (cadr quote) (1+ base-level))) 222 | ((not (zerop base-level)) 223 | ;; "real"-quote inside "quasi"-quote -> an ordinary symbol 224 | (highlight-stages--jit-highlighter-1 225 | (car quote) (cadr quote) base-level)) 226 | (t 227 | ;; "real"-quote outside "quasi"-quote 228 | (when highlight-stages-highlight-real-quote 229 | (highlight-stages--make-overlay (car quote) (cadr quote) 1))))) 230 | (goto-char (cadr quote))) 231 | (t 232 | (save-excursion 233 | (highlight-stages--jit-highlighter-1 234 | (car escape) (cadr escape) (1- base-level))) 235 | (goto-char (cadr escape)))))))) 236 | 237 | ;; + matchers for lisp 238 | 239 | (defun highlight-stages-lisp-quote-matcher (&optional limit) 240 | (when (highlight-stages--search-forward-regexp 241 | "\\(?:`\\|\\(#?'\\)\\)\\|([\s\t\n]*\\(?:backquote\\|\\(quote\\)\\)[\s\t\n]+" limit) 242 | (prog1 (if (or (match-beginning 1) (match-beginning 2)) 'real t) 243 | (set-match-data 244 | (list (point) 245 | (progn (ignore-errors (forward-sexp 1)) (point))))))) 246 | 247 | (defun highlight-stages-lisp-escape-matcher (&optional limit) 248 | (when (highlight-stages--search-forward-regexp ",@?\\|([\s\t\n]*\\\\,@?+[\s\t\n]+" limit) 249 | (set-match-data 250 | (list (point) 251 | (progn (ignore-errors (forward-sexp 1)) (point)))) 252 | t)) 253 | 254 | ;; + matchers for clojure 255 | 256 | (defun highlight-stages-clojure-escape-matcher (&optional limit) 257 | (when (highlight-stages--search-forward-regexp "~@?" limit) 258 | (set-match-data 259 | (list (point) 260 | (progn (ignore-errors (forward-sexp 1)) (point)))) 261 | t)) 262 | 263 | ;; + matchers for metaocaml 264 | 265 | (defun highlight-stages-metaocaml-quote-matcher (&optional limit) 266 | (when (highlight-stages--search-forward-regexp "\\.<" limit) 267 | (let ((beg (point)) 268 | (level 0)) 269 | (while (and (highlight-stages--search-forward-regexp "\\(\\.<\\)\\|\\(>\\.\\)") 270 | (progn (cond ((match-beginning 1) 271 | (setq level (1+ level))) 272 | ((match-beginning 2) 273 | (setq level (1- level)))) 274 | (>= level 0)))) 275 | (set-match-data 276 | (list beg 277 | (if (>= level 0) (point-max) (match-beginning 0)))) 278 | t))) 279 | 280 | (defun highlight-stages-metaocaml-escape-matcher (&optional limit) 281 | (when (highlight-stages--search-forward-regexp "\\.~" limit) 282 | (set-match-data 283 | (list (point) 284 | (cond ((looking-at "\\(\\s.\\|\\s_\\)+\\(?:[\s\t\n]\\|$\\)") ; not a sexp 285 | (goto-char (match-end 1))) 286 | (t 287 | (ignore-errors (forward-sexp 1)) 288 | (point))))) 289 | t)) 290 | 291 | ;; + matchers for C/C++/Objc 292 | 293 | (defun highlight-stages-c-preprocessor-matcher (&optional limit) 294 | ;; we need to return 'real not to fall into an infinite recursion 295 | (and (highlight-stages--search-forward-regexp "^[\s\t]*#\\(?:.*\\\\\n\\)*.*$" limit) 296 | 'real)) 297 | 298 | ;; + the mode 299 | 300 | ;;;###autoload 301 | (define-minor-mode highlight-stages-mode 302 | "Highlight staged (quasi-quoted) expressions" 303 | :init-value nil 304 | :lighter "Stg" 305 | :global nil 306 | (if highlight-stages-mode 307 | (jit-lock-register 'highlight-stages-jit-highlighter) 308 | (jit-lock-unregister 'highlight-stages-jit-highlighter) 309 | (remove-overlays (point-min) (point-max) 'category 'highlight-stages))) 310 | 311 | ;;;###autoload 312 | (define-globalized-minor-mode highlight-stages-global-mode 313 | highlight-stages-mode 314 | (lambda () (highlight-stages-mode 1))) 315 | 316 | ;; + provide 317 | 318 | (provide 'highlight-stages) 319 | 320 | ;;; highlight-stages.el ends here 321 | -------------------------------------------------------------------------------- /screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/zk-phi/highlight-stages/95daa710f3d8fc83f42c5da38003fc71ae0da1fc/screenshot.png -------------------------------------------------------------------------------- /screenshot2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/zk-phi/highlight-stages/95daa710f3d8fc83f42c5da38003fc71ae0da1fc/screenshot2.png -------------------------------------------------------------------------------- /screenshot3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/zk-phi/highlight-stages/95daa710f3d8fc83f42c5da38003fc71ae0da1fc/screenshot3.png --------------------------------------------------------------------------------