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-disable-checker 'haskell-ghc) |
|
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 |
|
926 :modes '(haskell-mode) |
|
927 :next-checkers '((warning . haskell-hlint))) |
|
928 |
|
929 (provide 'stack-mode) |
|