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