| author | Luke Hoersten <luke@hoersten.org> |
| Fri, 18 Sep 2015 17:39:07 -0500 | |
| changeset 82 | 12cf67bc486c |
| parent 81 | 4da7819d1a1c |
| permissions | -rw-r--r-- |
| 80 | 1 |
;;; stack-mode.el --- A minor mode enabling various features based on |
2 |
;;; stack-ide. |
|
3 |
||
4 |
;; Copyright (c) 2015 Chris Done. |
|
5 |
||
6 |
;; This file 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 3, or (at your option) |
|
9 |
;; any later version. |
|
10 |
||
11 |
;; This file 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, see <http://www.gnu.org/licenses/>. |
|
18 |
||
19 |
;;; Code: |
|
20 |
||
21 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
22 |
;; Imports |
|
23 |
||
24 |
(require 'haskell-mode) |
|
25 |
(require 'haskell-cabal) |
|
26 |
(require 'cl-lib) |
|
27 |
(require 'fifo) |
|
28 |
(require 'flycheck) |
|
29 |
(require 'json) |
|
30 |
||
31 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
32 |
;; Modes |
|
33 |
||
34 |
(define-minor-mode stack-mode |
|
35 |
"A minor mode enabling various features based on stack-ide. |
|
36 |
||
37 |
Automatically starts and stops flycheck-mode when you |
|
38 |
enable/disable it. It makes this assumption in the interest of |
|
39 |
easier user experience. Disable with `stack-mode-manage-flycheck'." |
|
40 |
:lighter " Stack" |
|
41 |
:keymap (let ((map (make-sparse-keymap))) |
|
42 |
(define-key map (kbd "M-.") 'stack-mode-goto) |
|
43 |
(define-key map (kbd "C-c C-k") 'stack-mode-clear) |
|
44 |
(define-key map (kbd "C-c C-t") 'stack-mode-type) |
|
45 |
(define-key map (kbd "C-c C-i") 'stack-mode-info) |
|
46 |
(define-key map (kbd "C-c C-l") 'stack-mode-load) |
|
47 |
map) |
|
48 |
(when (buffer-file-name) |
|
49 |
(if stack-mode |
|
50 |
(progn (when (bound-and-true-p interactive-haskell-mode) |
|
51 |
(when (y-or-n-p "interactive-haskell-mode is enabled. Disable it?") |
|
52 |
(interactive-haskell-mode -1))) |
|
53 |
(when stack-mode-manage-flycheck |
|
54 |
(flycheck-mode 1) |
|
|
81
4da7819d1a1c
Simplified haskell-init.el.
Luke Hoersten <luke@hoersten.org>
parents:
80
diff
changeset
|
55 |
(flycheck-disable-checker 'haskell-ghc) |
| 80 | 56 |
(flycheck-select-checker 'stack-ide) |
57 |
(flycheck-buffer))) |
|
58 |
(when stack-mode-manage-flycheck |
|
59 |
(flycheck-mode -1))))) |
|
60 |
||
61 |
(define-derived-mode inferior-stack-mode fundamental-mode "Inferior-Stack-IDE" |
|
62 |
"Major mode for interacting with an inferior stack-ide process.") |
|
63 |
||
64 |
(define-key inferior-stack-mode-map (kbd "C-c C-c") 'stack-mode-stop) |
|
65 |
(define-key inferior-stack-mode-map (kbd "C-c C-k") 'stack-mode-clear) |
|
66 |
||
67 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
68 |
;; Customization |
|
69 |
||
70 |
(defgroup stack-mode nil |
|
71 |
"IDE backend support for Haskell." |
|
72 |
:group 'haskell) |
|
73 |
||
74 |
(defcustom stack-mode-proc-path |
|
75 |
"stack" |
|
76 |
"Path to the stack executable." |
|
77 |
:type 'string |
|
78 |
:group 'stack-mode) |
|
79 |
||
80 |
(defcustom stack-mode-manage-flycheck |
|
81 |
t |
|
82 |
"Automatically start and stop flycheck when the minor mode is |
|
83 |
enabled/disabled." |
|
84 |
:type 'boolean |
|
85 |
:group 'stack-mode) |
|
86 |
||
87 |
(defcustom stack-mode-print-error-messages |
|
88 |
nil |
|
89 |
"Print error messages after loading the project?" |
|
90 |
:type 'boolean |
|
91 |
:group 'stack-mode) |
|
92 |
||
93 |
(defcustom stack-mode-show-popup |
|
94 |
nil |
|
95 |
"Show type and info messages in a popup?" |
|
96 |
:type 'boolean |
|
97 |
:group 'stack-mode) |
|
98 |
||
99 |
(defvar stack-mode-queue nil) |
|
100 |
(make-variable-buffer-local 'stack-mode-queue) |
|
101 |
||
102 |
(defvar stack-mode-back-queue nil) |
|
103 |
(make-variable-buffer-local 'stack-mode-back-queue) |
|
104 |
||
105 |
(defvar stack-mode-buffer nil) |
|
106 |
(make-variable-buffer-local 'stack-mode-buffer) |
|
107 |
||
108 |
(defvar stack-mode-name nil) |
|
109 |
(make-variable-buffer-local 'stack-mode-name) |
|
110 |
||
111 |
(defvar stack-mode-tried-to-start nil) |
|
112 |
(make-variable-buffer-local 'stack-mode-tried-to-start) |
|
113 |
||
114 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
115 |
;; Interactive functions |
|
116 |
||
117 |
(defun stack-mode-status () |
|
118 |
"Print the status of the current stack process." |
|
119 |
(interactive) |
|
120 |
(if (stack-mode-buffer) |
|
121 |
(if (stack-mode-process) |
|
122 |
(if (process-live-p (stack-mode-process)) |
|
123 |
(message "The process is live.") |
|
124 |
(message "There is a Stack process, but it's dead.")) |
|
125 |
(message "There is a stack buffer, but no Stack process.")) |
|
126 |
(message "There is no Stack buffer."))) |
|
127 |
||
128 |
(defun stack-mode-start () |
|
129 |
"Start an inferior process and buffer." |
|
130 |
(interactive) |
|
131 |
(if (stack-mode-live-p) |
|
132 |
(switch-to-buffer (stack-mode-buffer)) |
|
133 |
(with-current-buffer (stack-mode-buffer) |
|
134 |
(setq buffer-read-only t) |
|
135 |
(inferior-stack-mode) |
|
136 |
(stack-mode-set-initial-command) |
|
137 |
(setq stack-mode-buffer "") |
|
138 |
(let* ((project-name (stack-mode-name)) |
|
139 |
(name (stack-mode-process-name project-name)) |
|
140 |
(args (append (list name |
|
141 |
nil |
|
142 |
stack-mode-proc-path |
|
143 |
"ide" |
|
144 |
"start") |
|
145 |
(list project-name))) |
|
146 |
(process (or (get-process name) |
|
147 |
(progn (stack-mode-log "Starting: %S" args) |
|
148 |
(apply #'start-process |
|
149 |
args))))) |
|
150 |
(set-process-sentinel process 'stack-mode-sentinel) |
|
151 |
(set-process-filter process 'stack-mode-filter))))) |
|
152 |
||
153 |
(defun stack-mode-set-initial-command () |
|
154 |
"Set the initial command callback. The `stack ide` command will |
|
155 |
reload targets on start-up, so that's the default command we'll |
|
156 |
start with." |
|
157 |
(setq stack-mode-current-command |
|
158 |
(list :json nil |
|
159 |
:data nil |
|
160 |
:cont 'stack-mode-loading-callback |
|
161 |
:label nil)) |
|
162 |
(setq stack-mode-queue (fifo-make)) |
|
163 |
(stack-mode-log "Set initial command.")) |
|
164 |
||
165 |
(defun stack-mode-stop () |
|
166 |
"Stop the process." |
|
167 |
(interactive) |
|
168 |
(with-current-buffer (stack-mode-buffer) |
|
169 |
(when (stack-mode-process) |
|
170 |
(setq stack-mode-current-command nil) |
|
171 |
(setq stack-mode-buffer "") |
|
172 |
(kill-process (stack-mode-process)) |
|
173 |
(delete-process (stack-mode-process))))) |
|
174 |
||
175 |
(defun stack-mode-reset () |
|
176 |
"Reset the process." |
|
177 |
(interactive) |
|
178 |
(with-current-buffer (stack-mode-buffer) |
|
179 |
(when (stack-mode-process) |
|
180 |
(setq stack-mode-current-command nil) |
|
181 |
(setq stack-mode-buffer "") |
|
182 |
(setq stack-mode-queue (fifo-make))))) |
|
183 |
||
184 |
(defun stack-mode-restart () |
|
185 |
"Restart the process with a fresh command queue." |
|
186 |
(interactive) |
|
187 |
(stack-mode-stop) |
|
188 |
(stack-mode-start)) |
|
189 |
||
190 |
(defun stack-mode-live-p () |
|
191 |
"Is the process alive?" |
|
192 |
(and (stack-mode-process) |
|
193 |
(process-live-p (stack-mode-process)))) |
|
194 |
||
195 |
(defun stack-mode-clear () |
|
196 |
"Clear the interaction buffer." |
|
197 |
(interactive) |
|
198 |
(with-current-buffer (stack-mode-buffer) |
|
199 |
(let ((inhibit-read-only t)) |
|
200 |
(erase-buffer)))) |
|
201 |
||
202 |
(defun stack-mode-load () |
|
203 |
"Load the current buffer's file." |
|
204 |
(interactive) |
|
205 |
(save-buffer) |
|
206 |
(with-current-buffer (stack-mode-buffer) |
|
207 |
(stack-mode-reload))) |
|
208 |
||
209 |
(defun stack-mode-goto () |
|
210 |
"Go to definition of thing at point." |
|
211 |
(interactive) |
|
212 |
(let ((filename (buffer-file-name)) |
|
213 |
(module-name (haskell-guess-module-name)) |
|
214 |
(span (stack-mode-span))) |
|
215 |
(let* ((span-info |
|
216 |
(stack-mode-get-span-info |
|
217 |
module-name |
|
218 |
(with-current-buffer (stack-mode-buffer) |
|
219 |
(file-relative-name filename default-directory)) |
|
220 |
span)) |
|
221 |
(infos |
|
222 |
(stack-contents |
|
223 |
span-info)) |
|
224 |
(_ (when (and (vectorp infos) (= 0 (length infos))) |
|
225 |
(error "Couldn't find location for this. Is the module loaded in the backend? |
|
226 |
Run `M-x stack-mode-list-loaded-modules' to see what's loaded."))) |
|
227 |
(parts (mapcar #'identity (elt infos 0))) |
|
228 |
(info (stack-contents (elt parts 0))) |
|
229 |
(span (elt parts 1)) |
|
230 |
(scope (stack-lookup 'tag (stack-lookup 'idScope info))) |
|
231 |
(def-span (stack-lookup-contents |
|
232 |
'idDefSpan |
|
233 |
(stack-lookup 'idProp info)))) |
|
234 |
(cond |
|
235 |
((listp def-span) |
|
236 |
(stack-mode-goto-span def-span)) |
|
237 |
(t |
|
238 |
(let* ((imported-from |
|
239 |
(stack-lookup |
|
240 |
'idImportedFrom |
|
241 |
(stack-lookup 'idScope info))) |
|
242 |
(imported-module (stack-lookup 'moduleName imported-from)) |
|
243 |
(defined-in (stack-lookup |
|
244 |
'idDefinedIn |
|
245 |
(stack-lookup 'idProp info))) |
|
246 |
(package (stack-lookup 'modulePackage defined-in)) |
|
247 |
(package-name (stack-lookup 'packageName package)) |
|
248 |
(package-ver (stack-lookup 'packageVersion package)) |
|
249 |
(module (stack-lookup 'moduleName defined-in))) |
|
250 |
(message "Imported via %s, defined in %s (%s-%s)" |
|
251 |
(haskell-fontify-as-mode imported-module 'haskell-mode) |
|
252 |
(haskell-fontify-as-mode module 'haskell-mode) |
|
253 |
package-name |
|
254 |
package-ver))))))) |
|
255 |
||
256 |
(defun stack-mode-list-loaded-modules () |
|
257 |
"List the loaded modules in the backend." |
|
258 |
(interactive) |
|
259 |
(let ((modules |
|
260 |
(stack-contents |
|
261 |
(with-current-buffer (stack-mode-buffer) |
|
262 |
(stack-mode-call |
|
263 |
`((tag . "RequestGetLoadedModules") |
|
264 |
(contents |
|
265 |
. []))))))) |
|
266 |
(pop-to-buffer (stack-mode-buffer)) |
|
267 |
(stack-mode-log "Loaded modules: %s" |
|
268 |
(mapconcat #'identity |
|
269 |
(sort (mapcar #'identity modules) #'string<) |
|
270 |
"\n")))) |
|
271 |
||
272 |
(defun stack-mode-info () |
|
273 |
"Display the info of the thing at point." |
|
274 |
(interactive) |
|
275 |
(let* ((filename (buffer-file-name)) |
|
276 |
(module-name (haskell-guess-module-name)) |
|
277 |
(points (stack-mode-points)) |
|
278 |
(orig (point)) |
|
279 |
(span (stack-mode-span-from-points (car points) |
|
280 |
(cdr points))) |
|
281 |
(info (stack-mode-get-span-info |
|
282 |
module-name |
|
283 |
(with-current-buffer (stack-mode-buffer) |
|
284 |
(file-relative-name filename default-directory)) |
|
285 |
span)) |
|
286 |
(info-contents (stack-contents (elt (elt (stack-contents info) 0) 0))) |
|
287 |
(scope (stack-lookup 'idScope info-contents)) |
|
288 |
(prop (stack-lookup 'idProp info-contents)) |
|
289 |
(qual (stack-lookup 'idImportQual scope)) |
|
290 |
(from (stack-lookup 'idImportedFrom scope)) |
|
291 |
(span (stack-lookup 'idImportSpan scope)) |
|
292 |
||
293 |
(space (stack-lookup 'idSpace prop)) |
|
294 |
(idDefSpan (stack-lookup 'idDefSpan prop)) |
|
295 |
(idDefinedIn (stack-lookup 'idDefinedIn prop)) |
|
296 |
(modulePackage (stack-lookup 'modulePackage idDefinedIn)) |
|
297 |
(moduleName (stack-lookup 'moduleName idDefinedIn)) |
|
298 |
(packageVersion (stack-lookup 'packageVersion modulePackage)) |
|
299 |
(packageKey (stack-lookup 'packageKey modulePackage)) |
|
300 |
(packageName (stack-lookup 'packageKey modulePackage)) |
|
301 |
(idType (stack-lookup 'idType prop)) |
|
302 |
(idName (stack-lookup 'idName prop))) |
|
303 |
(let ((info-string (concat |
|
304 |
"Identifier: " (haskell-fontify-as-mode idName 'haskell-mode) "\n" |
|
305 |
"Type: " (haskell-fontify-as-mode idType 'haskell-mode) "\n" |
|
306 |
"Module: " (haskell-fontify-as-mode moduleName 'haskell-mode) "\n" |
|
307 |
"Package: " (if (string= "main" packageName) |
|
308 |
"(this one)" |
|
309 |
packageName)))) |
|
310 |
(cond (stack-mode-show-popup |
|
311 |
(when (boundp popup-tip) |
|
312 |
(popup-tip info-string))) |
|
313 |
(t (message info-string)))))) |
|
314 |
||
315 |
(defun stack-mode-type (&optional insert-value) |
|
316 |
"Display type info of thing at point." |
|
317 |
(interactive "P") |
|
318 |
(let* ((filename (buffer-file-name)) |
|
319 |
(module-name (haskell-guess-module-name)) |
|
320 |
(points (stack-mode-points)) |
|
321 |
(orig (point)) |
|
322 |
(span (stack-mode-span-from-points (car points) |
|
323 |
(cdr points)))) |
|
324 |
(let* ((types (stack-contents |
|
325 |
(stack-mode-get-exp-types |
|
326 |
module-name |
|
327 |
(with-current-buffer (stack-mode-buffer) |
|
328 |
(file-relative-name filename default-directory)) |
|
329 |
span))) |
|
330 |
(types (mapcar #'identity types)) |
|
331 |
(code (buffer-substring-no-properties |
|
332 |
(car points) |
|
333 |
(cdr points))) |
|
334 |
(type (stack-contents (car types))) |
|
335 |
(ty (stack-lookup 'text type))) |
|
336 |
(if insert-value |
|
337 |
(let ((ident-pos (haskell-ident-pos-at-point))) |
|
338 |
(cond |
|
339 |
((region-active-p) |
|
340 |
(delete-region (region-beginning) |
|
341 |
(region-end)) |
|
342 |
(insert "(" code " :: " ty ")") |
|
343 |
(goto-char (1+ orig))) |
|
344 |
((= (line-beginning-position) (car ident-pos)) |
|
345 |
(goto-char (line-beginning-position)) |
|
346 |
(insert code " :: " (haskell-fontify-as-mode ty 'haskell-mode) |
|
347 |
"\n")) |
|
348 |
(t |
|
349 |
(save-excursion |
|
350 |
(goto-char (car ident-pos)) |
|
351 |
(let ((col (current-column))) |
|
352 |
(save-excursion (insert "\n") |
|
353 |
(indent-to col)) |
|
354 |
(insert code " :: " (haskell-fontify-as-mode ty 'haskell-mode))))))) |
|
355 |
(unless (null types) |
|
356 |
(let ((type-string (format "%s" |
|
357 |
(mapconcat (lambda (type) |
|
358 |
(haskell-fontify-as-mode |
|
359 |
(concat |
|
360 |
code |
|
361 |
" :: " |
|
362 |
(elt type 0)) |
|
363 |
'haskell-mode)) |
|
364 |
(cl-subseq types 0 1) |
|
365 |
"\n")))) |
|
366 |
(cond (stack-mode-show-popup (popup-tip type-string)) |
|
367 |
(t (message type-string))))))))) |
|
368 |
||
369 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
370 |
;; Process filters and sentinel |
|
371 |
||
372 |
(defun stack-mode-filter (process response) |
|
373 |
(with-current-buffer (stack-mode-buffer (stack-mode-name-from-process process)) |
|
374 |
(if stack-mode-current-command |
|
375 |
(let* ((lines (split-string (concat stack-mode-buffer response) "\n"))) |
|
376 |
(setq stack-mode-buffer (car (last lines))) |
|
377 |
(setq lines (butlast lines)) |
|
378 |
(let ((data (plist-get stack-mode-current-command :data)) |
|
379 |
(cont (plist-get stack-mode-current-command :cont))) |
|
380 |
(while lines |
|
381 |
(let ((line (pop lines))) |
|
382 |
(stack-mode-log |
|
383 |
"%s <- %s" |
|
384 |
(if (plist-get stack-mode-current-command :label) |
|
385 |
(format "[%s]" (plist-get stack-mode-current-command :label)) |
|
386 |
"") |
|
387 |
(haskell-fontify-as-mode line 'javascript-mode)) |
|
388 |
(when (let* ((error-msg nil) |
|
389 |
(json (condition-case e |
|
390 |
(json-read-from-string line) |
|
391 |
(error "Problem reading JSON from server, probably an error message:\n%s" line))) |
|
392 |
(ret (condition-case e |
|
393 |
(funcall cont data json) |
|
394 |
(error (setq error-msg e) |
|
395 |
:error)))) |
|
396 |
(cl-ecase ret |
|
397 |
(:done t) |
|
398 |
(:continue nil) |
|
399 |
(:error |
|
400 |
(setq stack-mode-buffer "") |
|
401 |
(setq stack-mode-current-command nil) |
|
402 |
(setq stack-mode-queue nil) |
|
403 |
(error "Command handler error: %S\n\nThe command queue has been cleared." |
|
404 |
error-msg)) |
|
405 |
(t |
|
406 |
(error "A command handler must return either :done or :continue, |
|
407 |
but it returned: %S |
|
408 |
command was: %S" ret stack-mode-current-command)))) |
|
409 |
(cl-loop for line in lines |
|
410 |
do (stack-mode-log |
|
411 |
"Extraneous lines after command completed: %s" |
|
412 |
(haskell-fontify-as-mode line 'javascript-mode))) |
|
413 |
(setq stack-mode-current-command nil) |
|
414 |
(setq lines nil) |
|
415 |
(stack-mode-queue-trigger)))))) |
|
416 |
(stack-mode-log "Ignoring: %s" |
|
417 |
(haskell-fontify-as-mode response 'javascript-mode))))) |
|
418 |
||
419 |
(defun stack-mode-sentinel (process event) |
|
420 |
(with-current-buffer (stack-mode-buffer (stack-mode-name-from-process process)) |
|
421 |
(stack-mode-log "Process event: %s" event))) |
|
422 |
||
423 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
424 |
;; Command queue |
|
425 |
||
426 |
(defvar stack-mode-current-command nil |
|
427 |
"Current command handler.") |
|
428 |
(make-variable-buffer-local 'stack-mode-current-command) |
|
429 |
||
430 |
(defvar stack-mode-buffer "" |
|
431 |
"A buffer for the process.") |
|
432 |
(make-variable-buffer-local 'stack-mode-buffer) |
|
433 |
||
434 |
(defvar stack-mode-queue nil |
|
435 |
"Command queue.") |
|
436 |
(make-variable-buffer-local 'stack-mode-queue) |
|
437 |
||
438 |
(defun stack-mode-queue () |
|
439 |
"Get the FIFO queue of this process." |
|
440 |
(or stack-mode-queue |
|
441 |
(setq stack-mode-queue (fifo-make)))) |
|
442 |
||
443 |
(defun stack-mode-back-queue () |
|
444 |
"Get the FIFO back queue of this process." |
|
445 |
(or stack-mode-back-queue |
|
446 |
(setq stack-mode-back-queue (fifo-make)))) |
|
447 |
||
448 |
(defun stack-mode-enqueue-front (json data cont &optional label) |
|
449 |
"Enqueue a JSON command to the command queue, calling (CONT |
|
450 |
DATA line) for each response line until CONT returns nil. This is |
|
451 |
the first priority queue, anything pushed to this queue will be |
|
452 |
run before anything in the back queue." |
|
453 |
(cond |
|
454 |
((stack-mode-live-p) |
|
455 |
(stack-mode-log "[%s] => %s" label (haskell-fontify-as-mode (json-encode json) 'javascript-mode)) |
|
456 |
(fifo-push (stack-mode-queue) |
|
457 |
(list :json json :data data :cont cont :label label)) |
|
458 |
(stack-mode-queue-trigger)) |
|
459 |
(t (stack-mode-try-start)))) |
|
460 |
||
461 |
(defun stack-mode-enqueue (json data cont &optional label) |
|
462 |
"Same as `stack-mode-front', but puts it on the back |
|
463 |
queue. Items are only moved onto the front queue when the front |
|
464 |
queue is empty. This lets a command which consists of a few back |
|
465 |
and forth steps to continue its processing uninterrupted." |
|
466 |
(cond |
|
467 |
((stack-mode-live-p) |
|
468 |
(stack-mode-log "[%s] ~> %s" label (haskell-fontify-as-mode (json-encode json) 'javascript-mode)) |
|
469 |
(fifo-push (stack-mode-back-queue) |
|
470 |
(list :json json :data data :cont cont :label label)) |
|
471 |
(stack-mode-queue-trigger)) |
|
472 |
(t (stack-mode-try-start)))) |
|
473 |
||
474 |
(defun stack-mode-try-start () |
|
475 |
"Try to start, but only try once." |
|
476 |
(cond |
|
477 |
((not stack-mode-tried-to-start) |
|
478 |
(setq stack-mode-tried-to-start t) |
|
479 |
(message "Starting a Stack IDE backend process for this project: %s, stack directory: %s" |
|
480 |
(stack-mode-cabal-name) |
|
481 |
(stack-mode-dir)) |
|
482 |
(stack-mode-start)) |
|
483 |
(t (message "Attempted to run a Stack IDE command, but the server isn't started. We already tried once this session. Run `M-x stack-mode-restart` to confirm that you want to start it.")))) |
|
484 |
||
485 |
(defun stack-mode-call (json) |
|
486 |
"Call a JSON command. Wait for any existing queued commands to |
|
487 |
complete, then sends the request, blocking on the |
|
488 |
response. Returns the response." |
|
489 |
(let ((data (list nil))) |
|
490 |
(stack-mode-enqueue |
|
491 |
json data |
|
492 |
(lambda (data reply) |
|
493 |
(setcar data reply) |
|
494 |
:done)) |
|
495 |
(stack-mode-queue-flush) |
|
496 |
(car-safe data))) |
|
497 |
||
498 |
(defun stack-mode-queue-processed-p () |
|
499 |
"Return t if command queue has been completely processed." |
|
500 |
(and (fifo-null-p stack-mode-queue) |
|
501 |
(null stack-mode-current-command))) |
|
502 |
||
503 |
(defun stack-mode-queue-flush () |
|
504 |
"Block till PROCESS's command queue has been completely processed. |
|
505 |
This uses `accept-process-output' internally." |
|
506 |
(let ((proc (stack-mode-process))) |
|
507 |
(while (not (stack-mode-queue-processed-p)) |
|
508 |
(stack-mode-queue-trigger) |
|
509 |
(accept-process-output proc 1)))) |
|
510 |
||
511 |
(defun stack-mode-queue-trigger () |
|
512 |
"Trigger the next command in the queue if there is no current |
|
513 |
command." |
|
514 |
(if stack-mode-current-command |
|
515 |
(unless (fifo-null-p (stack-mode-queue)) |
|
516 |
(stack-mode-log "Stack command queue is currently active, waiting ...")) |
|
517 |
(when (fifo-null-p (stack-mode-queue)) |
|
518 |
(stack-mode-log "Command queue is now empty.") |
|
519 |
(unless (fifo-null-p (stack-mode-back-queue)) |
|
520 |
(stack-mode-log "Pushing next item from back queue to front queue ...") |
|
521 |
(fifo-push (stack-mode-queue) |
|
522 |
(fifo-pop (stack-mode-back-queue))))) |
|
523 |
(unless (fifo-null-p (stack-mode-queue)) |
|
524 |
(setq stack-mode-current-command |
|
525 |
(fifo-pop (stack-mode-queue))) |
|
526 |
(stack-mode-log |
|
527 |
"[%S] -> %s" |
|
528 |
(plist-get stack-mode-current-command :label) |
|
529 |
(haskell-fontify-as-mode |
|
530 |
(json-encode (plist-get stack-mode-current-command :json)) |
|
531 |
'javascript-mode)) |
|
532 |
(process-send-string |
|
533 |
(stack-mode-process) |
|
534 |
(concat (json-encode (plist-get stack-mode-current-command :json)) |
|
535 |
"\n"))))) |
|
536 |
||
537 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
538 |
;; Project functions |
|
539 |
||
540 |
(defun stack-mode-packages () |
|
541 |
"Get packages for the Stack configuration." |
|
542 |
(split-string (shell-command-to-string "stack ide packages") "\n" t)) |
|
543 |
||
544 |
(defun stack-mode-process () |
|
545 |
"Get the current process." |
|
546 |
(get-process (stack-mode-process-name (stack-mode-name)))) |
|
547 |
||
548 |
(defun stack-mode-buffer (&optional name) |
|
549 |
"The inferior buffer." |
|
550 |
(let ((default-directory (stack-mode-dir))) |
|
551 |
(get-buffer-create |
|
552 |
(stack-mode-buffer-name |
|
553 |
(or name |
|
554 |
(stack-mode-name)))))) |
|
555 |
||
556 |
(defun stack-mode-name-from-process (proc) |
|
557 |
"Get the name of the project from the process." |
|
558 |
(substring (process-name proc) (length "stack:"))) |
|
559 |
||
560 |
(defun stack-mode-process-name (name) |
|
561 |
"Name for the inferior process." |
|
562 |
(format "stack:%s" |
|
563 |
name)) |
|
564 |
||
565 |
(defun stack-mode-buffer-name (name) |
|
566 |
"Name for the inferior buffer." |
|
567 |
(format "*stack:%s*" |
|
568 |
name)) |
|
569 |
||
570 |
(defun stack-mode-dir () |
|
571 |
"The directory for the project." |
|
572 |
(file-name-directory (haskell-cabal-find-file))) |
|
573 |
||
574 |
(defun stack-mode-name () |
|
575 |
"The name for the current project based on the current |
|
576 |
directory." |
|
577 |
(or stack-mode-name |
|
578 |
(setq stack-mode-name |
|
579 |
(stack-mode-cabal-name)))) |
|
580 |
||
581 |
(defun stack-mode-cabal-name () |
|
582 |
"Get the name of the session to use, based on the cabal file." |
|
583 |
(let ((cabal-file (haskell-cabal-find-file))) |
|
584 |
(if (string-match "\\([^\\/]+\\)\\.cabal$" cabal-file) |
|
585 |
(let ((name (match-string 1 cabal-file))) |
|
586 |
(when (not (member name (stack-mode-packages))) |
|
587 |
(message "This cabal project “%s” isn't in your stack.yaml configuration." name)) |
|
588 |
name) |
|
589 |
(progn (message "Couldn't figure out cabal file, assuming no project.") |
|
590 |
nil)))) |
|
591 |
||
592 |
(defun stack-mode-log (&rest args) |
|
593 |
"Log a string to the inferior buffer." |
|
594 |
(with-current-buffer (stack-mode-buffer) |
|
595 |
(goto-char (point-max)) |
|
596 |
(let ((inhibit-read-only t)) |
|
597 |
(insert (apply #'format args) |
|
598 |
"\n")))) |
|
599 |
||
600 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
601 |
;; Commands |
|
602 |
||
603 |
(defun stack-mode-reload () |
|
604 |
"Compile the code and fetch compile errors." |
|
605 |
(with-current-buffer (stack-mode-buffer) |
|
606 |
(stack-mode-enqueue |
|
607 |
`((tag . "RequestUpdateSession") |
|
608 |
(contents . [])) |
|
609 |
nil |
|
610 |
'stack-mode-loading-callback))) |
|
611 |
||
612 |
;; (defun stack-mode-load-buffer () |
|
613 |
;; "Compile the code and fetch compile errors." |
|
614 |
;; (interactive) |
|
615 |
;; (with-current-buffer (stack-mode-buffer) |
|
616 |
;; (stack-mode-enqueue |
|
617 |
;; `((tag . "RequestUpdateSession") |
|
618 |
;; (contents . [((tag . "RequestUpdateTargets") |
|
619 |
;; (contents . ((tag . "TargetsInclude") |
|
620 |
;; (contents . ["src/Stack/Package.hs"]))))])) |
|
621 |
;; nil |
|
622 |
;; 'stack-mode-loading-callback))) |
|
623 |
||
624 |
(defun stack-mode-get-span-info (module file span) |
|
625 |
"Get the span info of the given location." |
|
626 |
(with-current-buffer (stack-mode-buffer) |
|
627 |
(stack-mode-call |
|
628 |
`((tag . "RequestGetSpanInfo") |
|
629 |
(contents |
|
630 |
. ((spanFilePath . ,file) |
|
631 |
(spanFromLine . ,(plist-get span :sl)) |
|
632 |
(spanFromColumn . ,(plist-get span :sc)) |
|
633 |
(spanToLine . ,(plist-get span :el)) |
|
634 |
(spanToColumn . ,(plist-get span :ec)))))))) |
|
635 |
||
636 |
(defun stack-mode-get-exp-types (module file span) |
|
637 |
"Get the type info of the given location." |
|
638 |
(with-current-buffer (stack-mode-buffer) |
|
639 |
(stack-mode-call |
|
640 |
`((tag . "RequestGetExpTypes") |
|
641 |
(contents |
|
642 |
. ((spanFilePath . ,file) |
|
643 |
(spanFromLine . ,(plist-get span :sl)) |
|
644 |
(spanFromColumn . ,(plist-get span :sc)) |
|
645 |
(spanToLine . ,(plist-get span :el)) |
|
646 |
(spanToColumn . ,(plist-get span :ec)))))))) |
|
647 |
||
648 |
(defun stack-mode-get-use-sites (module file span) |
|
649 |
"Get all uses of an identifier." |
|
650 |
) |
|
651 |
||
652 |
(defun stack-mode-get-completions (module string) |
|
653 |
"Get all uses of an identifier." |
|
654 |
) |
|
655 |
||
656 |
(defun stack-mode-loading-callback (_ reply) |
|
657 |
"Callback for when loading modules." |
|
658 |
(let ((tag (stack-tag reply))) |
|
659 |
(cond |
|
660 |
((string= tag "ResponseUpdateSession") |
|
661 |
(let* ((contents (stack-contents reply)) |
|
662 |
(tag (stack-tag contents))) |
|
663 |
(cond |
|
664 |
((string= tag "UpdateStatusProgress") |
|
665 |
(stack-mode-progress-callback _ reply) |
|
666 |
:continue) |
|
667 |
((string= tag "UpdateStatusDone") |
|
668 |
(stack-mode-enqueue-front |
|
669 |
`((tag . "RequestGetSourceErrors") |
|
670 |
(contents . [])) |
|
671 |
nil |
|
672 |
'stack-mode-get-source-errors-callback) |
|
673 |
:done) |
|
674 |
(t :continue)))) |
|
675 |
(t |
|
676 |
:continue)))) |
|
677 |
||
678 |
(defun stack-mode-progress-callback (_ reply) |
|
679 |
"Callback for status reports. Utilized in multiple places." |
|
680 |
(let* ((contents (stack-contents reply)) |
|
681 |
(update (stack-contents contents)) |
|
682 |
(step (stack-lookup 'progressStep update)) |
|
683 |
(total (stack-lookup 'progressNumSteps update)) |
|
684 |
(msg (stack-lookup 'progressParsedMsg update))) |
|
685 |
(message "[%s/%s] %s" |
|
686 |
(propertize (number-to-string step) 'face 'compilation-line-number) |
|
687 |
(propertize (number-to-string total) 'face 'compilation-line-number) |
|
688 |
msg))) |
|
689 |
||
690 |
(defun stack-mode-get-source-errors-callback (_ reply) |
|
691 |
"Handle the reply from getting source errors." |
|
692 |
(let ((tag (stack-tag reply))) |
|
693 |
(cond |
|
694 |
((string= tag "ResponseGetSourceErrors") |
|
695 |
(let ((any-errors nil) |
|
696 |
(warnings 0)) |
|
697 |
(cl-loop |
|
698 |
for item in (mapcar #'identity (stack-contents reply)) |
|
699 |
do (let* ((kind (stack-lookup 'errorKind item)) |
|
700 |
(span (stack-contents (stack-lookup 'errorSpan item))) |
|
701 |
(msg (stack-lookup 'errorMsg item)) |
|
702 |
(fp (stack-lookup 'spanFilePath span)) |
|
703 |
(sl (stack-lookup 'spanFromLine span)) |
|
704 |
(sc (stack-lookup 'spanFromColumn span)) |
|
705 |
(el (stack-lookup 'spanToLine span)) |
|
706 |
(ec (stack-lookup 'spanToColumn span))) |
|
707 |
(cond ((string= kind "KindError") |
|
708 |
(setq any-errors t)) |
|
709 |
((string= kind "KindWarning") |
|
710 |
(setq warnings (1+ warnings)))) |
|
711 |
(when |
|
712 |
stack-mode-print-error-messages |
|
713 |
(message "%s" |
|
714 |
(propertize |
|
715 |
(format "%s:(%d,%d)-(%d,%d): \n%s" |
|
716 |
fp sl sc el ec msg) |
|
717 |
'face |
|
718 |
(cond |
|
719 |
((string= kind "KindWarning") |
|
720 |
'compilation-warning) |
|
721 |
((string= kind "KindError") |
|
722 |
'compilation-error))))))) |
|
723 |
(unless any-errors |
|
724 |
(if (= 0 warnings) |
|
725 |
(message "OK.") |
|
726 |
(message (propertize "OK (%d warning%s)." 'face 'compilation-warning) |
|
727 |
warnings |
|
728 |
(if (= 1 warnings) "" "s"))))) |
|
729 |
:done) |
|
730 |
(t :done)))) |
|
731 |
||
732 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
733 |
;; Span functions |
|
734 |
||
735 |
(defun stack-mode-points () |
|
736 |
"Get the current points; either a selected region or an |
|
737 |
identifier's points." |
|
738 |
(if (region-active-p) |
|
739 |
(cons (region-beginning) (region-end)) |
|
740 |
(let ((ident (haskell-ident-pos-at-point))) |
|
741 |
(cons (car ident) |
|
742 |
(cdr ident))))) |
|
743 |
||
744 |
(defun stack-mode-span-from-points (beg end) |
|
745 |
"Get the span representation for the span from BEG to END." |
|
746 |
(save-excursion |
|
747 |
(list :sl (progn (goto-char beg) |
|
748 |
(line-number-at-pos)) |
|
749 |
:sc (1+ (current-column)) |
|
750 |
:el (progn (goto-char end) |
|
751 |
(line-number-at-pos)) |
|
752 |
:ec (1+ (current-column))))) |
|
753 |
||
754 |
(defun stack-mode-span () |
|
755 |
"Get the span from the haskell points." |
|
756 |
(let ((points (or (haskell-spanable-pos-at-point) |
|
757 |
(haskell-ident-pos-at-point) |
|
758 |
(stack-mode-loose-ident-at-point)))) |
|
759 |
(if points |
|
760 |
(stack-mode-span-from-points (car points) (cdr points)) |
|
761 |
(error "No identifier at point.")))) |
|
762 |
||
763 |
(defun stack-mode-goto-span (span) |
|
764 |
"Get buffer points from a span." |
|
765 |
(with-current-buffer (stack-mode-buffer) |
|
766 |
(find-file (stack-lookup 'spanFilePath span)) |
|
767 |
(goto-char (point-min)) |
|
768 |
(let ((beg (point))) |
|
769 |
(goto-char (point-min)) |
|
770 |
(forward-line (1- (stack-lookup 'spanFromLine span))) |
|
771 |
(goto-char (line-beginning-position)) |
|
772 |
(forward-char (1- (stack-lookup 'spanFromColumn span)))))) |
|
773 |
||
774 |
(defun stack-mode-loose-ident-at-point () |
|
775 |
"Get the loose ident at point." |
|
776 |
nil) |
|
777 |
||
778 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
779 |
;; JSON helpers |
|
780 |
||
781 |
(defun stack-mode-list->hashtable (xs) |
|
782 |
"Convert a list to a hashtable." |
|
783 |
(let ((h (make-hash-table))) |
|
784 |
(cl-loop for (key . val) |
|
785 |
in xs |
|
786 |
do (puthash key val h)) |
|
787 |
h)) |
|
788 |
||
789 |
(defun stack-lookup (key object) |
|
790 |
"Get from a JSON object." |
|
791 |
(cdr (assoc key (mapcar #'identity object)))) |
|
792 |
||
793 |
(defun stack-contents (object) |
|
794 |
"Get from a JSON object." |
|
795 |
(stack-lookup 'contents object)) |
|
796 |
||
797 |
(defun stack-tag (object) |
|
798 |
"Get the tag of an object." |
|
799 |
(stack-lookup 'tag object)) |
|
800 |
||
801 |
(defun stack-lookup-contents (key object) |
|
802 |
"Get from a JSON object." |
|
803 |
(stack-contents (stack-lookup key object))) |
|
804 |
||
805 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
806 |
;; Flycheck integration |
|
807 |
||
808 |
(defun stack-mode-flycheck-start (checker flycheck-callback &optional buffer attempt-count) |
|
809 |
"Run a compile on demand, triggered by Flycheck." |
|
810 |
(when buffer (set-buffer buffer)) |
|
811 |
(let ((max-attempts 2)) |
|
812 |
(if (not (stack-mode-live-p)) |
|
813 |
(if (> (or attempt-count 0) max-attempts) |
|
814 |
(stack-mode-log "Stack backend isn't ready for Flycheck use. Giving up (waited %d seconds)." |
|
815 |
max-attempts) |
|
816 |
(stack-mode-log "Stack backend isn't ready. Waiting (%d attempts) ..." |
|
817 |
(or attempt-count 0)) |
|
818 |
(progn (stack-mode-log "Flycheck tried to use the Stack backend, but the Stack backend isn't started yet. Starting it ...") |
|
819 |
(stack-mode-try-start) |
|
820 |
(run-with-idle-timer 1 nil 'stack-mode-flycheck-start checker flycheck-callback |
|
821 |
(current-buffer) |
|
822 |
(1+ (or attempt-count 0))))) |
|
823 |
(progn (stack-mode-log "Running Flycheck with Stack backend ...") |
|
824 |
(write-region (point-min) (point-max) (buffer-file-name)) |
|
825 |
(clear-visited-file-modtime) |
|
826 |
(let ((source-buffer (current-buffer)) |
|
827 |
(label (format "flycheck %s" (buffer-name (current-buffer))))) |
|
828 |
(with-current-buffer (stack-mode-buffer) |
|
829 |
(stack-mode-enqueue |
|
830 |
`((tag . "RequestUpdateSession") |
|
831 |
(contents . [])) |
|
832 |
(list :flycheck-callback flycheck-callback |
|
833 |
:stack-buffer (current-buffer) |
|
834 |
:source-buffer source-buffer |
|
835 |
:label label) |
|
836 |
'stack-mode-flycheck-callback |
|
837 |
label))))))) |
|
838 |
||
839 |
(defun stack-mode-flycheck-callback (state reply) |
|
840 |
"Callback for the flycheck loading. Once done, it will report |
|
841 |
errors/warnings to CALLBACK." |
|
842 |
(let ((tag (stack-tag reply))) |
|
843 |
(cond |
|
844 |
((string= tag "ResponseUpdateSession") |
|
845 |
(let* ((contents (stack-contents reply)) |
|
846 |
(tag (stack-tag contents))) |
|
847 |
(cond |
|
848 |
((string= tag "UpdateStatusProgress") |
|
849 |
(stack-mode-progress-callback nil reply) |
|
850 |
:continue) |
|
851 |
((string= tag "UpdateStatusDone") |
|
852 |
(stack-mode-enqueue-front |
|
853 |
`((tag . "RequestGetSourceErrors") |
|
854 |
(contents . [])) |
|
855 |
state |
|
856 |
'stack-mode-flycheck-errors-callback |
|
857 |
(plist-get state :label)) |
|
858 |
:done) |
|
859 |
(t :continue)))) |
|
860 |
(t |
|
861 |
:continue)))) |
|
862 |
||
863 |
(defun stack-mode-flycheck-errors-callback (state reply) |
|
864 |
"Collect error messages and pass them to FLYCHECK-CALLBACK." |
|
865 |
(let ((tag (stack-tag reply))) |
|
866 |
(cond |
|
867 |
((string= tag "ResponseGetSourceErrors") |
|
868 |
(let ((messages (list))) |
|
869 |
(cl-loop |
|
870 |
for item in (mapcar #'identity (stack-contents reply)) |
|
871 |
do (let* ((kind (stack-lookup 'errorKind item)) |
|
872 |
(span (stack-contents (stack-lookup 'errorSpan item))) |
|
873 |
(msg (stack-lookup 'errorMsg item)) |
|
874 |
(filename (stack-lookup 'spanFilePath span)) |
|
875 |
(sl (stack-lookup 'spanFromLine span)) |
|
876 |
(sc (stack-lookup 'spanFromColumn span)) |
|
877 |
(el (stack-lookup 'spanToLine span)) |
|
878 |
(ec (stack-lookup 'spanToColumn span))) |
|
879 |
(let ((orig (current-buffer)) |
|
880 |
(buffer |
|
881 |
(with-current-buffer (plist-get state :stack-buffer) |
|
882 |
(let ((value (get-file-buffer filename))) |
|
883 |
(if (listp value) |
|
884 |
(car value) |
|
885 |
value))))) |
|
886 |
(if (not (null buffer)) |
|
887 |
(add-to-list |
|
888 |
'messages |
|
889 |
(flycheck-error-new-at |
|
890 |
sl sc |
|
891 |
(cond |
|
892 |
((string= kind "KindWarning") 'warning) |
|
893 |
((string= kind "KindError") 'error) |
|
894 |
(t (message "kind: %s" kind)'error)) |
|
895 |
msg |
|
896 |
:checker 'stack-ide |
|
897 |
:buffer buffer) |
|
898 |
t)) |
|
899 |
(set-buffer orig)))) |
|
900 |
;; Calling it asynchronously is necessary for flycheck to |
|
901 |
;; work properly. See |
|
902 |
;; <https://github.com/flycheck/flycheck/pull/524#issuecomment-64947118> |
|
903 |
;; |
|
904 |
;; Also, the `stack-mode-call-in-buffer' utility is also |
|
905 |
;; needed because the reply needs to be called in the same |
|
906 |
;; buffer. |
|
907 |
(run-with-idle-timer 0 |
|
908 |
nil |
|
909 |
'stack-mode-call-in-buffer |
|
910 |
(plist-get state :source-buffer) |
|
911 |
(plist-get state :flycheck-callback) |
|
912 |
'finished |
|
913 |
messages) |
|
914 |
(message "Flycheck done.")) |
|
915 |
:done) |
|
916 |
(t :done)))) |
|
917 |
||
918 |
(defun stack-mode-call-in-buffer (buffer func &rest args) |
|
919 |
"Utility function which calls FUNC in BUFFER with ARGS." |
|
920 |
(with-current-buffer buffer |
|
921 |
(apply func args))) |
|
922 |
||
923 |
(flycheck-define-generic-checker 'stack-ide |
|
924 |
"A syntax and type checker for Haskell using Stack's IDE support." |
|
925 |
:start 'stack-mode-flycheck-start |
|
|
81
4da7819d1a1c
Simplified haskell-init.el.
Luke Hoersten <luke@hoersten.org>
parents:
80
diff
changeset
|
926 |
:modes '(haskell-mode) |
|
4da7819d1a1c
Simplified haskell-init.el.
Luke Hoersten <luke@hoersten.org>
parents:
80
diff
changeset
|
927 |
:next-checkers '((warning . haskell-hlint))) |
| 80 | 928 |
|
929 |
(provide 'stack-mode) |