|
| 1 | +;; Wrapper for CodeMirror-style emacs modes. Highlighting is done by |
| 2 | +;; running a stateful parser (with first-class state object) over the |
| 3 | +;; buffer, line by line, using the output to add 'face properties, and |
| 4 | +;; storing the parser state at the end of each line. Indentation is |
| 5 | +;; done based on the parser state at the start of the line. |
| 6 | + |
| 7 | +(eval-when-compile (require 'cl)) |
| 8 | + |
| 9 | +;; Mode data structure |
| 10 | + |
| 11 | +(defun make-cm-mode (token &optional start-state copy-state |
| 12 | + compare-state indent) |
| 13 | + (vector token |
| 14 | + (or start-state (lambda () 'null)) |
| 15 | + (or copy-state 'cm-default-copy-state) |
| 16 | + (or compare-state 'eq) |
| 17 | + indent)) |
| 18 | +(defmacro cm-mode-token (x) `(aref ,x 0)) |
| 19 | +(defmacro cm-mode-start-state (x) `(aref ,x 1)) |
| 20 | +(defmacro cm-mode-copy-state (x) `(aref ,x 2)) |
| 21 | +(defmacro cm-mode-compare-state (x) `(aref ,x 3)) |
| 22 | +(defmacro cm-mode-indent (x) `(aref ,x 4)) |
| 23 | + |
| 24 | +(defvar cm-cur-mode nil) |
| 25 | +(defvar cm-worklist nil) |
| 26 | + |
| 27 | +(defun cm-default-copy-state (state) |
| 28 | + (if (consp state) (copy-sequence state) state)) |
| 29 | + |
| 30 | +(defun cm-clear-work-items (from to) |
| 31 | + (let ((prev-cons nil) |
| 32 | + (rem cm-worklist)) |
| 33 | + (while rem |
| 34 | + (let ((pos (marker-position (car rem)))) |
| 35 | + (cond ((or (< pos from) (> pos to)) (setf prev-cons rem)) |
| 36 | + (prev-cons (setf (cdr prev-cons) (cdr rem))) |
| 37 | + (t (setf cm-worklist (cdr rem)))) |
| 38 | + (setf rem (cdr rem)))))) |
| 39 | + |
| 40 | +(defun cm-min-worklist-item () |
| 41 | + (let ((rest cm-worklist) (min most-positive-fixnum)) |
| 42 | + (while rest |
| 43 | + (let ((pos (marker-position (car rest)))) |
| 44 | + (when (< pos min) (setf min pos))) |
| 45 | + (setf rest (cdr rest))) |
| 46 | + min)) |
| 47 | + |
| 48 | +;; Indentation |
| 49 | + |
| 50 | +(defun cm-indent () |
| 51 | + (let (indent-pos) |
| 52 | + (save-excursion |
| 53 | + (beginning-of-line) |
| 54 | + (let* ((buf (current-buffer)) |
| 55 | + (state (cm-preserve-state buf 'cm-state-for-point)) |
| 56 | + (old-indent (current-indentation))) |
| 57 | + (back-to-indentation) |
| 58 | + (setf indent-pos (point)) |
| 59 | + (let ((new-indent (funcall (cm-mode-indent cm-cur-mode) state))) |
| 60 | + (unless (= old-indent new-indent) |
| 61 | + (indent-line-to new-indent) |
| 62 | + (setf indent-pos (point)) |
| 63 | + (beginning-of-line) |
| 64 | + (cm-preserve-state buf |
| 65 | + (lambda () |
| 66 | + (cm-highlight-line state) |
| 67 | + (when (< (point) (point-max)) |
| 68 | + (put-text-property (point) (+ (point) 1) 'cm-parse-state state)))))))) |
| 69 | + (when (< (point) indent-pos) |
| 70 | + (goto-char indent-pos)))) |
| 71 | + |
| 72 | +(defun cm-backtrack-to-state () |
| 73 | + (let ((backtracked 0) |
| 74 | + (min-indent most-positive-fixnum) |
| 75 | + min-indented) |
| 76 | + (loop |
| 77 | + (when (= (point) (point-min)) |
| 78 | + (return (funcall (cm-mode-start-state cm-cur-mode)))) |
| 79 | + (let ((st (get-text-property (- (point) 1) 'cm-parse-state))) |
| 80 | + (when (and st (save-excursion |
| 81 | + (backward-char) |
| 82 | + (beginning-of-line) |
| 83 | + (not (looking-at "[ ]*$")))) |
| 84 | + (return (funcall (cm-mode-copy-state cm-cur-mode) st)))) |
| 85 | + (let ((i (current-indentation))) |
| 86 | + (when (< i min-indent) |
| 87 | + (setf min-indent i min-indented (point)))) |
| 88 | + (when (> (incf backtracked) 30) |
| 89 | + (goto-char min-indented) |
| 90 | + (return (funcall (cm-mode-start-state cm-cur-mode)))) |
| 91 | + (forward-line -1)))) |
| 92 | + |
| 93 | +(defun cm-state-for-point () |
| 94 | + (let ((pos (point)) |
| 95 | + (state (cm-backtrack-to-state))) |
| 96 | + (while (< (point) pos) |
| 97 | + (cm-highlight-line state) |
| 98 | + (put-text-property (point) (+ (point) 1) 'cm-parse-state |
| 99 | + (funcall (cm-mode-copy-state cm-cur-mode) state)) |
| 100 | + (forward-char)) |
| 101 | + state)) |
| 102 | + |
| 103 | +;; Highlighting |
| 104 | + |
| 105 | +(defun cm-highlight-line (state) |
| 106 | + (let ((eol (point-at-eol))) |
| 107 | + (remove-text-properties (point) eol '(face)) |
| 108 | + (loop |
| 109 | + (let ((p (point))) |
| 110 | + (when (= p eol) (return)) |
| 111 | + (let ((style (funcall (cm-mode-token cm-cur-mode) state))) |
| 112 | + (when (= p (point)) (print (point)) (error "Nothing consumed.")) |
| 113 | + (when (> p eol) (error "Parser moved past EOL")) |
| 114 | + (when style |
| 115 | + (put-text-property p (point) 'face style))))))) |
| 116 | + |
| 117 | +(defun cm-find-state-before-point () |
| 118 | + (loop |
| 119 | + (beginning-of-line) |
| 120 | + (when (= (point) 1) |
| 121 | + (return (funcall (cm-mode-start-state cm-cur-mode)))) |
| 122 | + (let ((cur (get-text-property (- (point) 1) 'cm-parse-state))) |
| 123 | + (when cur (return (funcall (cm-mode-copy-state cm-cur-mode) cur)))) |
| 124 | + (backward-char))) |
| 125 | + |
| 126 | +(defun cm-schedule-work (delay) |
| 127 | + (run-with-idle-timer delay nil 'cm-preserve-state (current-buffer) 'cm-do-some-work)) |
| 128 | + |
| 129 | +(defun cm-preserve-state (buffer f &rest args) |
| 130 | + (with-current-buffer buffer |
| 131 | + (let ((modified (buffer-modified-p)) |
| 132 | + (buffer-undo-list t) |
| 133 | + (inhibit-read-only t) |
| 134 | + (inhibit-point-motion-hooks t) |
| 135 | + (inhibit-modification-hooks t)) |
| 136 | + (unwind-protect (apply f args) |
| 137 | + (unless modified |
| 138 | + (restore-buffer-modified-p nil)))))) |
| 139 | + |
| 140 | +(defun cm-do-some-work-inner () |
| 141 | + (let ((end-time (time-add (current-time) (list 0 0 500))) |
| 142 | + (quitting nil)) |
| 143 | + (while (and (not quitting) cm-worklist) |
| 144 | + (goto-char (cm-min-worklist-item)) |
| 145 | + (let ((state (cm-find-state-before-point)) |
| 146 | + (startpos (point)) |
| 147 | + (timer-idle-list nil)) |
| 148 | + (loop |
| 149 | + (cm-highlight-line state) |
| 150 | + (when (= (point) (point-max)) (return)) |
| 151 | + (let ((old (get-text-property (point) 'cm-parse-state))) |
| 152 | + (when (and old (funcall (cm-mode-compare-state cm-cur-mode) state old)) |
| 153 | + (return)) |
| 154 | + (put-text-property (point) (+ (point) 1) 'cm-parse-state |
| 155 | + (funcall (cm-mode-copy-state cm-cur-mode) state))) |
| 156 | + (when (or (let ((timer-idle-list nil)) (input-pending-p)) |
| 157 | + (time-less-p end-time (current-time))) |
| 158 | + (setf quitting t) (return)) |
| 159 | + (forward-char)) |
| 160 | + (cm-clear-work-items startpos (point))) |
| 161 | + (when quitting |
| 162 | + (push (copy-marker (+ (point) 1)) cm-worklist) |
| 163 | + (cm-schedule-work 0.05))))) |
| 164 | + |
| 165 | +(defun cm-do-some-work () |
| 166 | + (save-excursion |
| 167 | + (condition-case cnd (cm-do-some-work-inner) |
| 168 | + (error (print cnd) (error cnd))))) |
| 169 | + |
| 170 | +(defun cm-after-change-function (from to oldlen) |
| 171 | + (cm-preserve-state (current-buffer) 'remove-text-properties from to '(cm-parse-state)) |
| 172 | + (push (copy-marker from) cm-worklist) |
| 173 | + (cm-schedule-work 0.2)) |
| 174 | + |
| 175 | +;; Entry function |
| 176 | + |
| 177 | +(defun cm-mode (mode) |
| 178 | + (set (make-local-variable 'cm-cur-mode) mode) |
| 179 | + (set (make-local-variable 'cm-worklist) (list (copy-marker 1))) |
| 180 | + (when (cm-mode-indent mode) |
| 181 | + (set (make-local-variable 'indent-line-function) 'cm-indent)) |
| 182 | + (add-hook 'after-change-functions 'cm-after-change-function t t) |
| 183 | + (add-hook 'after-revert-hook (lambda () (cm-after-change-function 1 (point-max) nil)) t t) |
| 184 | + (cm-schedule-work 0.05)) |
| 185 | + |
| 186 | +(provide 'cm-mode) |
0 commit comments