summaryrefslogtreecommitdiff
path: root/.stack-work/install/x86_64-linux/lts-13.22/8.6.5/share/x86_64-linux-ghc-8.6.5/intero-0.1.40/elisp/intero.el
diff options
context:
space:
mode:
Diffstat (limited to '.stack-work/install/x86_64-linux/lts-13.22/8.6.5/share/x86_64-linux-ghc-8.6.5/intero-0.1.40/elisp/intero.el')
-rw-r--r--.stack-work/install/x86_64-linux/lts-13.22/8.6.5/share/x86_64-linux-ghc-8.6.5/intero-0.1.40/elisp/intero.el3676
1 files changed, 0 insertions, 3676 deletions
diff --git a/.stack-work/install/x86_64-linux/lts-13.22/8.6.5/share/x86_64-linux-ghc-8.6.5/intero-0.1.40/elisp/intero.el b/.stack-work/install/x86_64-linux/lts-13.22/8.6.5/share/x86_64-linux-ghc-8.6.5/intero-0.1.40/elisp/intero.el
deleted file mode 100644
index a1dd48e..0000000
--- a/.stack-work/install/x86_64-linux/lts-13.22/8.6.5/share/x86_64-linux-ghc-8.6.5/intero-0.1.40/elisp/intero.el
+++ /dev/null
@@ -1,3676 +0,0 @@
1;;; intero.el --- Complete development mode for Haskell
2
3;; Copyright (c) 2016 Chris Done
4;; Copyright (c) 2016 Steve Purcell
5;; Copyright (C) 2016 Артур Файзрахманов
6;; Copyright (c) 2015 Athur Fayzrakhmanov
7;; Copyright (C) 2015 Gracjan Polak
8;; Copyright (c) 2013 Herbert Valerio Riedel
9;; Copyright (c) 2007 Stefan Monnier
10
11;; Author: Chris Done <chrisdone@fpcomplete.com>
12;; Maintainer: Chris Done <chrisdone@fpcomplete.com>
13;; URL: https://github.com/commercialhaskell/intero
14;; Created: 3rd June 2016
15;; Version: 0.1.13
16;; Keywords: haskell, tools
17;; Package-Requires: ((flycheck "0.25") (company "0.8") (emacs "24.4") (haskell-mode "13.0"))
18
19;; This file is free software; you can redistribute it and/or modify
20;; it under the terms of the GNU General Public License as published by
21;; the Free Software Foundation; either version 3, or (at your option)
22;; any later version.
23
24;; This file is distributed in the hope that it will be useful,
25;; but WITHOUT ANY WARRANTY; without even the implied warranty of
26;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
27;; GNU General Public License for more details.
28
29;; You should have received a copy of the GNU General Public License
30;; along with GNU Emacs; see the file COPYING. If not, write to
31;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
32;; Boston, MA 02110-1301, USA.
33
34;;; Commentary:
35;;
36;; Mode that enables:
37;;
38;; * Flycheck type checking ✓
39;; * Company mode completion ✓
40;; * Go to definition ✓
41;; * Type of selection ✓
42;; * Info ✓
43;; * REPL ✓
44;; * Apply suggestions (extensions, imports, etc.) ✓
45;; * Find uses
46;; * Completion of stack targets ✓
47;; * List all types in all expressions
48;; * Import management
49;; * Dependency management
50
51;;; Code:
52
53(require 'flycheck)
54(require 'json)
55(require 'warnings)
56(require 'cl-lib)
57(require 'company)
58(require 'comint)
59(require 'widget)
60(require 'eldoc)
61(eval-when-compile
62 (require 'wid-edit))
63(require 'tramp)
64
65;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
66;; Configuration
67
68(defgroup intero nil
69 "Complete development mode for Haskell"
70 :group 'haskell)
71
72(defcustom intero-package-version
73 (cl-case system-type
74 ;; Until <https://github.com/haskell/network/issues/313> is fixed:
75 (windows-nt "0.1.39")
76 (cygwin "0.1.39")
77 (t "0.1.39"))
78 "Package version to auto-install.
79
80This version does not necessarily have to be the latest version
81of intero published on Hackage. Sometimes there are changes to
82Intero which have no use for the Emacs mode. It is only bumped
83when the Emacs mode actually requires newer features from the
84intero executable, otherwise we force our users to upgrade
85pointlessly."
86 :group 'intero
87 :type 'string)
88
89(defcustom intero-repl-no-load
90 t
91 "Pass --no-load when starting the repl.
92This causes it to skip loading the files from the selected target."
93 :group 'intero
94 :type 'boolean)
95
96(defcustom intero-repl-no-build
97 t
98 "Pass --no-build when starting the repl.
99This causes it to skip building the target."
100 :group 'intero
101 :type 'boolean)
102
103(defcustom intero-debug nil
104 "Show debug output."
105 :group 'intero
106 :type 'boolean)
107
108(defcustom intero-whitelist
109 nil
110 "Projects to whitelist.
111
112It should be a list of directories.
113
114To use this, use the following mode hook:
115 (add-hook 'haskell-mode-hook 'intero-mode-whitelist)
116or use `intero-global-mode' and add \"/\" to `intero-blacklist'."
117 :group 'intero
118 :type 'string)
119
120(defcustom intero-blacklist
121 nil
122 "Projects to blacklist.
123
124It should be a list of directories.
125
126To use this, use the following mode hook:
127 (add-hook 'haskell-mode-hook 'intero-mode-blacklist)
128or use `intero-global-mode'."
129 :group 'intero
130 :type 'string)
131
132(defcustom intero-stack-executable
133 "stack"
134 "Name or path to the Stack executable to use."
135 :group 'intero
136 :type 'string)
137
138(defcustom intero-pop-to-repl
139 t
140 "When non-nil, pop to REPL when code is sent to it."
141 :group 'intero
142 :type 'boolean)
143
144(defcustom intero-extra-ghc-options nil
145 "Extra GHC options to pass to intero executable.
146
147For example, this variable can be used to run intero with extra
148warnings and perform more checks via flycheck error reporting."
149 :group 'intero
150 :type '(repeat string))
151
152(defcustom intero-extra-ghci-options nil
153 "Extra options to pass to GHCi when running `intero-repl'.
154
155For example, this variable can be used to enable some ghci extensions
156by default."
157 :group 'intero
158 :type '(repeat string))
159
160;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
161;; Modes
162
163(defvar intero-mode-map (make-sparse-keymap)
164 "Intero minor mode's map.")
165
166(defvar-local intero-lighter " Intero"
167 "Lighter for the intero minor mode.")
168
169;;;###autoload
170(define-minor-mode intero-mode
171 "Minor mode for Intero.
172
173\\{intero-mode-map}"
174 :lighter intero-lighter
175 :keymap intero-mode-map
176 (when (bound-and-true-p interactive-haskell-mode)
177 (when (fboundp 'interactive-haskell-mode)
178 (message "Disabling interactive-haskell-mode ...")
179 (interactive-haskell-mode -1)))
180 (if intero-mode
181 (progn
182 (intero-flycheck-enable)
183 (add-hook 'completion-at-point-functions 'intero-completion-at-point nil t)
184 (add-to-list (make-local-variable 'company-backends) 'intero-company)
185 (company-mode)
186 (setq-local company-minimum-prefix-length 1)
187 (unless eldoc-documentation-function
188 (setq-local eldoc-documentation-function #'ignore))
189 (add-function :before-until (local 'eldoc-documentation-function) #'intero-eldoc)
190 )
191 (progn
192 (remove-function (local 'eldoc-documentation-function) #'intero-eldoc)
193 (message "Intero mode disabled."))))
194
195;;;###autoload
196(defun intero-mode-whitelist ()
197 "Run intero-mode when the current project is in `intero-whitelist'."
198 (interactive)
199 (when (intero-directories-contain-file (buffer-file-name) intero-whitelist)
200 (intero-mode)))
201
202;;;###autoload
203(defun intero-mode-blacklist ()
204 "Run intero-mode unless the current project is in `intero-blacklist'."
205 (interactive)
206 (unless (intero-directories-contain-file (buffer-file-name) intero-blacklist)
207 (intero-mode)))
208
209(dolist (f '(intero-mode-whitelist intero-mode-blacklist))
210 (make-obsolete
211 f
212 "use `intero-global-mode', which honours `intero-whitelist' and `intero-blacklist'."
213 "2017-05-13"))
214
215
216(define-key intero-mode-map (kbd "C-c C-t") 'intero-type-at)
217(define-key intero-mode-map (kbd "M-?") 'intero-uses-at)
218(define-key intero-mode-map (kbd "C-c C-i") 'intero-info)
219(define-key intero-mode-map (kbd "M-.") 'intero-goto-definition)
220(define-key intero-mode-map (kbd "C-c C-l") 'intero-repl-load)
221(define-key intero-mode-map (kbd "C-c C-c") 'intero-repl-eval-region)
222(define-key intero-mode-map (kbd "C-c C-z") 'intero-repl)
223(define-key intero-mode-map (kbd "C-c C-r") 'intero-apply-suggestions)
224(define-key intero-mode-map (kbd "C-c C-e") 'intero-expand-splice-at-point)
225
226(defun intero-directories-contain-file (file dirs)
227 "Return non-nil if FILE is contained in at least one of DIRS."
228 (and (not (null file))
229 (cl-some (lambda (directory)
230 (file-in-directory-p file directory))
231 dirs)))
232
233(defun intero-mode-maybe ()
234 "Enable `intero-mode' in all Haskell mode buffers.
235The buffer's filename (or working directory) is checked against
236`intero-whitelist' and `intero-blacklist'. If both the whitelist
237and blacklist match, then the whitelist entry wins, and
238`intero-mode' is enabled."
239 (when (intero-mode-should-start-p)
240 (intero-mode 1)))
241
242(defun intero-mode-should-start-p ()
243 "Predicate whether intero should start given user config.
244The buffer's filename (or working directory) is checked against
245`intero-whitelist' and `intero-blacklist'. If both the whitelist
246and blacklist match, then the whitelist entry wins, and
247`intero-mode' is enabled."
248 (and (derived-mode-p 'haskell-mode)
249 (let* ((file (or (buffer-file-name) default-directory))
250 (blacklisted (intero-directories-contain-file
251 file intero-blacklist))
252 (whitelisted (intero-directories-contain-file
253 file intero-whitelist)))
254 (or whitelisted (not blacklisted)))))
255
256;;;###autoload
257(define-globalized-minor-mode intero-global-mode
258 intero-mode intero-mode-maybe
259 :require 'intero)
260
261(define-obsolete-function-alias 'global-intero-mode 'intero-global-mode)
262
263
264;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
265;; Global variables/state
266
267(defvar intero-temp-file-buffer-mapping
268 (make-hash-table)
269 "A mapping from file names to buffers.")
270
271;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
272;; Buffer-local variables/state
273
274(defvar-local intero-callbacks (list)
275 "List of callbacks waiting for output.
276LIST is a FIFO.")
277
278(defvar-local intero-async-network-cmd nil
279 "Command to send to the async network process when we connect.")
280
281(defvar-local intero-async-network-connected nil
282 "Did we successfully connect to the intero service?")
283
284(defvar-local intero-async-network-state nil
285 "State to pass to the callback once we get a response.")
286
287(defvar-local intero-async-network-worker nil
288 "The worker we're associated with.")
289
290(defvar-local intero-async-network-callback nil
291 "Callback to call when the connection is closed.")
292
293(defvar-local intero-arguments (list)
294 "Arguments used to call the stack process.")
295
296(defvar-local intero-targets (list)
297 "Targets used for the stack process.")
298
299(defvar-local intero-repl-last-loaded nil
300 "Last loaded module in the REPL.")
301
302(defvar-local intero-repl-send-after-load nil
303 "Send a command after every load.")
304
305(defvar-local intero-start-time nil
306 "Start time of the stack process.")
307
308(defvar-local intero-source-buffer (list)
309 "Buffer from which Intero was first requested to start.")
310
311(defvar-local intero-project-root nil
312 "The project root of the current buffer.")
313
314(defvar-local intero-package-name nil
315 "The package name associated with the current buffer.")
316
317(defvar-local intero-deleting nil
318 "The process of the buffer is being deleted.")
319
320(defvar-local intero-give-up nil
321 "When non-nil, give up trying to start the backend.
322A true value indicates that the backend could not start, or could
323not be installed. The user will have to manually run
324`intero-restart' or `intero-targets' to destroy the buffer and
325create a fresh one without this variable enabled.")
326
327(defvar-local intero-try-with-build nil
328 "Try starting intero without --no-build.
329This is slower, but will build required dependencies.")
330
331(defvar-local intero-starting nil
332 "When non-nil, indicates that the intero process starting up.")
333
334(defvar-local intero-service-port nil
335 "Port that the intero process is listening on for asynchronous commands.")
336
337(defvar-local intero-hoogle-port nil
338 "Port that hoogle server is listening on.")
339
340(defvar-local intero-suggestions nil
341 "Auto actions for the buffer.")
342
343(defvar-local intero-extensions nil
344 "Extensions supported by the compiler.")
345
346(defvar-local intero-ghc-version nil
347 "GHC version used by the project.")
348
349(defvar-local intero-buffer-host nil
350 "The hostname of the box hosting the intero process for the current buffer.")
351
352(defvar-local intero-stack-yaml nil
353 "The yaml file that intero should tell stack to use. When nil,
354 intero relies on stack's default, usually the 'stack.yaml' in
355 the project root.")
356
357(defun intero-inherit-local-variables (buffer)
358 "Make the current buffer inherit values of certain local variables from BUFFER."
359 (let ((variables '(intero-stack-executable
360 intero-repl-no-build
361 intero-repl-no-load
362 intero-stack-yaml
363 ;; TODO: shouldn’t more of the above be here?
364 )))
365 (cl-loop for v in variables do
366 (set (make-local-variable v) (buffer-local-value v buffer)))))
367
368(defmacro intero-with-temp-buffer (&rest body)
369 "Run BODY in `with-temp-buffer', but inherit certain local variables from the current buffer first."
370 (declare (indent 0) (debug t))
371 `(let ((initial-buffer (current-buffer)))
372 (with-temp-buffer
373 (intero-inherit-local-variables initial-buffer)
374 ,@body)))
375
376;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
377;; Interactive commands
378
379(defun intero-add-package (package)
380 "Add a dependency on PACKAGE to the currently-running project backend."
381 (interactive "sPackage: ")
382 (intero-blocking-call 'backend (concat ":set -package " package))
383 (flycheck-buffer))
384
385(defun intero-toggle-debug ()
386 "Toggle debugging mode on/off."
387 (interactive)
388 (setq intero-debug (not intero-debug))
389 (message "Intero debugging is: %s" (if intero-debug "ON" "OFF")))
390
391(defun intero-list-buffers ()
392 "List hidden process buffers created by intero.
393
394You can use this to kill them or look inside."
395 (interactive)
396 (let ((buffers (cl-remove-if-not
397 (lambda (buffer)
398 (string-match-p " intero:" (buffer-name buffer)))
399 (buffer-list))))
400 (if buffers
401 (display-buffer
402 (list-buffers-noselect
403 nil
404 buffers))
405 (error "There are no Intero process buffers"))))
406
407(defun intero-cd ()
408 "Change directory in the backend process."
409 (interactive)
410 (intero-async-call
411 'backend
412 (concat ":cd "
413 (read-directory-name "Change Intero directory: "))))
414
415(defun intero-fontify-expression (expression)
416 "Return a haskell-fontified version of EXPRESSION."
417 (intero-with-temp-buffer
418 (when (fboundp 'haskell-mode)
419 (let ((flycheck-checkers nil)
420 (haskell-mode-hook nil))
421 (haskell-mode)))
422 (insert expression)
423 (if (fboundp 'font-lock-ensure)
424 (font-lock-ensure)
425 (font-lock-fontify-buffer))
426 (buffer-string)))
427
428(defun intero-uses-at ()
429 "Highlight where the identifier at point is used."
430 (interactive)
431 (let* ((thing (intero-thing-at-point))
432 (uses (split-string (apply #'intero-get-uses-at thing)
433 "\n"
434 t)))
435 (unless (null uses)
436 (let ((highlighted nil))
437 (cl-loop
438 for use in uses
439 when (string-match
440 "\\(.*?\\):(\\([0-9]+\\),\\([0-9]+\\))-(\\([0-9]+\\),\\([0-9]+\\))$"
441 use)
442 do (let* ((returned-file (match-string 1 use))
443 (loaded-file (intero-extend-path-by-buffer-host returned-file))
444 (sline (string-to-number (match-string 2 use)))
445 (scol (string-to-number (match-string 3 use)))
446 (eline (string-to-number (match-string 4 use)))
447 (ecol (string-to-number (match-string 5 use)))
448 (start (save-excursion (goto-char (point-min))
449 (forward-line (1- sline))
450 (forward-char (1- scol))
451 (point))))
452 (when (intero-temp-file-p loaded-file)
453 (unless highlighted
454 (intero-highlight-uses-mode))
455 (setq highlighted t)
456 (intero-highlight-uses-mode-highlight
457 start
458 (save-excursion (goto-char (point-min))
459 (forward-line (1- eline))
460 (forward-char (1- ecol))
461 (point))
462 (= start (car thing))))))))))
463
464(defun intero-type-at (insert)
465 "Get the type of the thing or selection at point.
466
467With prefix argument INSERT, inserts the type above the current
468line as a type signature."
469 (interactive "P")
470 (let* ((thing (intero-thing-at-point))
471 (origin-buffer (current-buffer))
472 (origin (buffer-name))
473 (package (intero-package-name))
474 (ty (apply #'intero-get-type-at thing))
475 (string (buffer-substring (nth 0 thing) (nth 1 thing))))
476 (if insert
477 (save-excursion
478 (goto-char (line-beginning-position))
479 (insert (intero-fontify-expression ty) "\n"))
480 (with-current-buffer (intero-help-buffer)
481 (let ((buffer-read-only nil)
482 (help-string
483 (concat
484 (intero-fontify-expression string)
485 " in `"
486 (propertize origin 'origin-buffer origin-buffer)
487 "'"
488 " (" package ")"
489 "\n\n"
490 (intero-fontify-expression ty))))
491 (erase-buffer)
492 (intero-help-push-history origin-buffer help-string)
493 (intero-help-pagination)
494 (insert help-string)
495 (goto-char (point-min))))
496 (message
497 "%s" (intero-fontify-expression ty)))))
498
499(defun intero-info (ident)
500 "Get the info of the thing with IDENT at point."
501 (interactive (list (intero-ident-at-point)))
502 (let ((origin-buffer (current-buffer))
503 (package (intero-package-name))
504 (info (intero-get-info-of ident))
505 (origin (buffer-name)))
506 (with-current-buffer (pop-to-buffer (intero-help-buffer))
507 (let ((buffer-read-only nil)
508 (help-string
509 (concat
510 (intero-fontify-expression ident)
511 " in `"
512 (propertize origin 'origin-buffer origin-buffer)
513 "'"
514 " (" package ")"
515 "\n\n"
516 (intero-fontify-expression info))))
517 (erase-buffer)
518 (intero-help-push-history origin-buffer help-string)
519 (intero-help-pagination)
520 (insert help-string)
521 (goto-char (point-min))))))
522
523(defun intero-goto-definition ()
524 "Jump to the definition of the thing at point.
525Returns nil when unable to find definition."
526 (interactive)
527 (let ((result (apply #'intero-get-loc-at (intero-thing-at-point))))
528
529 (if (not (string-match "\\(.*?\\):(\\([0-9]+\\),\\([0-9]+\\))-(\\([0-9]+\\),\\([0-9]+\\))$"
530 result))
531 (message "%s" result)
532 (if (fboundp 'xref-push-marker-stack) ;; Emacs 25
533 (xref-push-marker-stack)
534 (with-no-warnings
535 (ring-insert find-tag-marker-ring (point-marker))))
536 (let* ((returned-file (match-string 1 result))
537 (line (string-to-number (match-string 2 result)))
538 (col (string-to-number (match-string 3 result)))
539 (loaded-file (intero-extend-path-by-buffer-host returned-file)))
540 (if (intero-temp-file-p loaded-file)
541 (let ((original-buffer (intero-temp-file-origin-buffer loaded-file)))
542 (if original-buffer
543 (switch-to-buffer original-buffer)
544 (error "Attempted to load temp file. Try restarting Intero.
545If the problem persists, please report this as a bug!")))
546 (find-file
547 (expand-file-name
548 returned-file
549 (intero-extend-path-by-buffer-host (intero-project-root)))))
550 (pop-mark)
551 (goto-char (point-min))
552 (forward-line (1- line))
553 (forward-char (1- col))
554 t))))
555
556(defmacro intero-with-dump-splices (exp)
557 "Run EXP but with dump-splices enabled in the intero backend process."
558 `(when (intero-blocking-call 'backend ":set -ddump-splices")
559 (let ((result ,exp))
560 (progn
561 nil ; Disable dump-splices here in future
562 result))))
563
564(defun intero-expand-splice-at-point ()
565 "Show the expansion of the template haskell splice at point."
566 (interactive)
567 (unless (intero-gave-up 'backend)
568 (intero-with-dump-splices
569 (let* ((output (intero-blocking-call
570 'backend
571 (concat ":load " (intero-path-for-ghci (intero-temp-file-name)))))
572 (msgs (intero-parse-errors-warnings-splices nil (current-buffer) output))
573 (line (line-number-at-pos))
574 (column (if (save-excursion
575 (forward-char 1)
576 (looking-back "$(" 1))
577 (+ 2 (current-column))
578 (if (looking-at-p "$(")
579 (+ 3 (current-column))
580 (1+ (current-column)))))
581 (expansion-msg
582 (cl-loop for msg in msgs
583 when (and (eq (flycheck-error-level msg) 'splice)
584 (= (flycheck-error-line msg) line)
585 (<= (flycheck-error-column msg) column))
586 return (flycheck-error-message msg)))
587 (expansion
588 (when expansion-msg
589 (string-trim
590 (replace-regexp-in-string "^Splicing expression" "" expansion-msg)))))
591 (when expansion
592 (message "%s" (intero-fontify-expression expansion)))))))
593
594(defun intero-restart ()
595 "Simply restart the process with the same configuration as before."
596 (interactive)
597 (when (intero-buffer-p 'backend)
598 (let ((targets (buffer-local-value 'intero-targets
599 (intero-buffer 'backend)))
600 (stack-yaml (buffer-local-value 'intero-stack-yaml
601 (intero-buffer 'backend))))
602 (intero-destroy 'backend)
603 (intero-get-worker-create 'backend targets (current-buffer) stack-yaml)
604 (intero-repl-restart))))
605
606(defun intero-read-targets ()
607 "Read a list of stack targets."
608 (let ((old-targets
609 (buffer-local-value 'intero-targets (intero-buffer 'backend)))
610 (available-targets (intero-get-targets)))
611 (if available-targets
612 (intero-multiswitch
613 "Set the targets to use for stack ghci:"
614 (mapcar (lambda (target)
615 (list :key target
616 :title target
617 :default (member target old-targets)))
618 available-targets))
619 (split-string (read-from-minibuffer "Targets: " nil nil nil nil old-targets)
620 " "
621 t))))
622
623(defun intero-targets (targets save-dir-local)
624 "Set the TARGETS to use for stack ghci.
625When SAVE-DIR-LOCAL is non-nil, save TARGETS as the
626directory-local value for `intero-targets'."
627 (interactive (list (intero-read-targets)
628 (y-or-n-p "Save selected target(s) in directory local variables for future sessions? ")))
629 (intero-destroy)
630 (intero-get-worker-create 'backend targets (current-buffer))
631 (intero-repl-restart)
632 (when save-dir-local
633 (save-window-excursion
634 (let ((default-directory (intero-project-root)))
635 (add-dir-local-variable 'haskell-mode 'intero-targets targets)
636 (save-buffer)))))
637
638(defun intero-stack-yaml (file save-dir-local)
639 "Change the yaml FILE that intero should tell stack to use.
640Intero will be restarted with the new configuration. When
641SAVE-DIR-LOCAL is non-nil, save FILE as the directory-local value
642for `intero-stack-yaml'."
643 (interactive (list (read-file-name
644 "Select YAML config: "
645 (file-name-as-directory (intero-project-root)))
646 (y-or-n-p "Save selected stack yaml config in directory local variable for future sessions? ")))
647 (let ((stack-yaml (expand-file-name file)))
648 (setq intero-stack-yaml stack-yaml)
649 (with-current-buffer (intero-buffer 'backend)
650 (setq intero-stack-yaml stack-yaml))
651 (intero-restart)
652 (intero-repl-restart)
653 (when save-dir-local
654 (save-window-excursion
655 (let ((default-directory (intero-project-root)))
656 (add-dir-local-variable 'haskell-mode 'intero-stack-yaml stack-yaml)
657 (save-buffer))))))
658
659(defun intero-destroy (&optional worker)
660 "Stop WORKER and kill its associated process buffer.
661If not provided, WORKER defaults to the current worker process."
662 (interactive)
663 (if worker
664 (intero-delete-worker worker)
665 (intero-delete-worker 'backend)))
666
667;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
668;; DevelMain integration
669
670(defun intero-devel-reload ()
671 "Reload the module `DevelMain' and then run `DevelMain.update'.
672
673This is for doing live update of the code of servers or GUI
674applications. Put your development version of the program in
675`DevelMain', and define `update' to auto-start the program on a
676new thread, and use the `foreign-store' package to access the
677running context across :load/:reloads in Intero."
678 (interactive)
679 (unwind-protect
680 (with-current-buffer
681 (or (get-buffer "DevelMain.hs")
682 (if (y-or-n-p
683 "You need to open a buffer named DevelMain.hs. Find now? ")
684 (ido-find-file)
685 (error "No DevelMain.hs buffer")))
686 (message "Reloading ...")
687 (intero-async-call
688 'backend
689 ":load DevelMain"
690 (current-buffer)
691 (lambda (buffer reply)
692 (if (string-match-p "^O[Kk], modules loaded" reply)
693 (intero-async-call
694 'backend
695 "DevelMain.update"
696 buffer
697 (lambda (_buffer reply)
698 (message "DevelMain updated. Output was:\n%s"
699 reply)))
700 (progn
701 (message "DevelMain FAILED. Switch to DevelMain.hs and compile that.")
702 (switch-to-buffer buffer)
703 (flycheck-buffer)
704 (flycheck-list-errors))))))))
705
706;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
707;; Flycheck integration
708
709(defun intero-flycheck-enable ()
710 "Enable intero's flycheck support in this buffer."
711 (flycheck-select-checker 'intero)
712 (setq intero-check-last-mod-time nil
713 intero-check-last-results nil)
714 (flycheck-mode))
715
716(defun intero-check (checker cont)
717 "Run a check with CHECKER and pass the status onto CONT."
718 (if (intero-gave-up 'backend)
719 (run-with-timer 0
720 nil
721 cont
722 'interrupted)
723 (let* ((file-buffer (current-buffer))
724 (staging-file (intero-path-for-ghci (intero-staging-file-name)))
725 (temp-file (intero-path-for-ghci (intero-temp-file-name))))
726 ;; We queue up to :move the staging file to the target temp
727 ;; file, which also updates its modified time.
728 (intero-async-call
729 'backend
730 (format ":move %s %s" staging-file temp-file))
731 ;; We load up the target temp file, which has only been updated
732 ;; by the copy above.
733 (intero-async-call
734 'backend
735 (concat ":load " temp-file)
736 (list :cont cont
737 :file-buffer file-buffer
738 :checker checker)
739 (lambda (state string)
740 (with-current-buffer (plist-get state :file-buffer)
741 (let* ((compile-ok (string-match "O[Kk], modules loaded: \\(.*\\)\\.$" string))
742 (modules (match-string 1 string))
743 (msgs (intero-parse-errors-warnings-splices
744 (plist-get state :checker)
745 (current-buffer)
746 string)))
747 (intero-collect-compiler-messages msgs)
748 (let ((results (cl-remove-if (lambda (msg)
749 (eq 'splice (flycheck-error-level msg)))
750 msgs)))
751 (setq intero-check-last-results results)
752 (funcall (plist-get state :cont) 'finished results))
753 (when compile-ok
754 (intero-async-call 'backend
755 (concat ":module + "
756 (replace-regexp-in-string "," "" modules))
757 nil
758 (lambda (_st _))))))))
759 ;; We sleep for at least one second to allow a buffer period
760 ;; between module updates. GHCi will consider a module Foo to be
761 ;; unchanged even if its filename has changed or timestmap has
762 ;; changed, if the timestamp is less than 1 second.
763 (intero-async-call
764 'backend
765 ":sleep 1"))))
766
767(flycheck-define-generic-checker 'intero
768 "A syntax and type checker for Haskell using an Intero worker
769process."
770 :start 'intero-check
771 :modes '(haskell-mode literate-haskell-mode)
772 :predicate (lambda () intero-mode))
773
774(add-to-list 'flycheck-checkers 'intero)
775
776(defun intero-parse-errors-warnings-splices (checker buffer string)
777 "Parse flycheck errors and warnings.
778CHECKER and BUFFER are added to each item parsed from STRING."
779 (intero-with-temp-buffer
780 (insert string)
781 (goto-char (point-min))
782 (let ((messages (list))
783 (temp-file (intero-temp-file-name buffer))
784 (found-error-as-warning nil))
785 (while (search-forward-regexp
786 (concat "[\r\n]\\([A-Z]?:?[^ \r\n:][^:\n\r]+\\):\\([0-9()-:]+\\):"
787 "[ \n\r]+\\([[:unibyte:][:nonascii:]]+?\\)\n[^ ]")
788 nil t 1)
789 (let* ((local-file (intero-canonicalize-path (match-string 1)))
790 (file (intero-extend-path-by-buffer-host local-file buffer))
791 (location-raw (match-string 2))
792 (msg (replace-regexp-in-string
793 "[\n\r ]*|$"
794 ""
795 (match-string 3))) ;; Replace gross bullet points.
796 (type (cond ((string-match "^Warning:" msg)
797 (setq msg (replace-regexp-in-string "^Warning: *" "" msg))
798 (if (string-match-p
799 (rx bol
800 "["
801 (or "-Wdeferred-type-errors"
802 "-Wdeferred-out-of-scope-variables"
803 "-Wtyped-holes")
804 "]")
805 msg)
806 (progn (setq found-error-as-warning t)
807 'error)
808 'warning))
809 ((string-match-p "^Splicing " msg) 'splice)
810 (t 'error)))
811 (location (intero-parse-error
812 (concat local-file ":" location-raw ": x")))
813 (line (plist-get location :line))
814 (column (plist-get location :col)))
815 (setq messages
816 (cons (flycheck-error-new-at
817 line column type
818 msg
819 :checker checker
820 :buffer buffer
821 :filename (if (intero-paths-for-same-file temp-file file)
822 (intero-buffer-file-name buffer)
823 file))
824 messages)))
825 (forward-line -1))
826 (delete-dups
827 (if found-error-as-warning
828 (cl-remove-if (lambda (msg) (eq 'warning (flycheck-error-level msg))) messages)
829 messages)))))
830
831(defconst intero-error-regexp-alist
832 `((,(concat
833 "^ *\\(?1:[^\t\r\n]+?\\):"
834 "\\(?:"
835 "\\(?2:[0-9]+\\):\\(?4:[0-9]+\\)\\(?:-\\(?5:[0-9]+\\)\\)?" ;; "121:1" & "12:3-5"
836 "\\|"
837 "(\\(?2:[0-9]+\\),\\(?4:[0-9]+\\))-(\\(?3:[0-9]+\\),\\(?5:[0-9]+\\))" ;; "(289,5)-(291,36)"
838 "\\)"
839 ":\\(?6: Warning:\\)?")
840 1 (2 . 3) (4 . 5) (6 . nil)) ;; error/warning locus
841
842 ;; multiple declarations
843 ("^ \\(?:Declared at:\\| \\) \\(?1:[^ \t\r\n]+\\):\\(?2:[0-9]+\\):\\(?4:[0-9]+\\)$"
844 1 2 4 0) ;; info locus
845
846 ;; this is the weakest pattern as it's subject to line wrapping et al.
847 (" at \\(?1:[^ \t\r\n]+\\):\\(?2:[0-9]+\\):\\(?4:[0-9]+\\)\\(?:-\\(?5:[0-9]+\\)\\)?[)]?$"
848 1 2 (4 . 5) 0)) ;; info locus
849 "Regexps used for matching GHC compile messages.")
850
851(defun intero-parse-error (string)
852 "Parse the line number from the error in STRING."
853 (save-match-data
854 (when (string-match (mapconcat #'car intero-error-regexp-alist "\\|")
855 string)
856 (let ((string3 (match-string 3 string))
857 (string5 (match-string 5 string)))
858 (list :file (match-string 1 string)
859 :line (string-to-number (match-string 2 string))
860 :col (string-to-number (match-string 4 string))
861 :line2 (when string3
862 (string-to-number string3))
863 :col2 (when string5
864 (string-to-number string5)))))))
865
866(defun intero-call-in-buffer (buffer func &rest args)
867 "In BUFFER, call FUNC with ARGS."
868 (with-current-buffer buffer
869 (apply func args)))
870
871;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
872;; Traditional completion-at-point function
873
874(defun intero-completion-at-point ()
875 "A (blocking) function suitable for use in `completion-at-point-functions'."
876 (let ((prefix-info (intero-completions-grab-prefix)))
877 (when prefix-info
878 (cl-destructuring-bind
879 (beg end prefix _type) prefix-info
880 (let ((completions
881 (intero-completion-response-to-list
882 (intero-blocking-call
883 'backend
884 (format ":complete repl %S" prefix)))))
885 (when completions
886 (list beg end completions)))))))
887
888(defun intero-repl-completion-at-point ()
889 "A (blocking) function suitable for use in `completion-at-point-functions'.
890Should only be used in the repl"
891 (let* ((beg (save-excursion (intero-repl-beginning-of-line) (point)))
892 (end (point))
893 (str (buffer-substring-no-properties beg end))
894 (repl-buffer (current-buffer))
895 (proc (get-buffer-process (current-buffer))))
896 (with-temp-buffer
897 (comint-redirect-send-command-to-process
898 (format ":complete repl %S" str) ;; command
899 (current-buffer) ;; output buffer
900 proc ;; target process
901 nil ;; echo
902 t) ;; no-display
903 (while (not (with-current-buffer repl-buffer
904 comint-redirect-completed))
905 (sleep-for 0.01))
906 (let* ((completions (intero-completion-response-to-list (buffer-string)))
907 (first-line (car completions)))
908 (when (string-match "[^ ]* [^ ]* " first-line) ;; "2 2 :load src/"
909 (setq first-line (replace-match "" nil nil first-line))
910 (list (+ beg (length first-line)) end (cdr completions)))))))
911
912;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
913;; Company integration (auto-completion)
914
915(defconst intero-pragmas
916 '("CONLIKE" "SCC" "DEPRECATED" "INCLUDE" "INCOHERENT" "INLINABLE" "INLINE"
917 "LANGUAGE" "LINE" "MINIMAL" "NOINLINE" "NOUNPACK" "OPTIONS" "OPTIONS_GHC"
918 "OVERLAPPABLE" "OVERLAPPING" "OVERLAPS" "RULES" "SOURCE" "SPECIALIZE"
919 "UNPACK" "WARNING")
920 "Pragmas that GHC supports.")
921
922(defun intero-company (command &optional arg &rest ignored)
923 "Company source for intero, with the standard COMMAND and ARG args.
924Other arguments are IGNORED."
925 (interactive (list 'interactive))
926 (cl-case command
927 (interactive (company-begin-backend 'intero-company))
928 (prefix
929 (unless (intero-gave-up 'backend)
930 (or (let ((hole (intero-grab-hole)))
931 (when hole
932 (save-excursion
933 (goto-char (cdr hole))
934 (buffer-substring (car hole) (cdr hole)))))
935 (let ((prefix-info (intero-completions-grab-prefix)))
936 (when prefix-info
937 (cl-destructuring-bind
938 (beg end prefix _type) prefix-info
939 prefix))))))
940 (candidates
941 (unless (intero-gave-up 'backend)
942 (let ((beg-end (intero-grab-hole)))
943 (if beg-end
944 (cons :async
945 (-partial 'intero-async-fill-at
946 (current-buffer)
947 (car beg-end)))
948 (let ((prefix-info (intero-completions-grab-prefix)))
949 (when prefix-info
950 (cons :async
951 (-partial 'intero-company-callback
952 (current-buffer)
953 prefix-info))))))))))
954
955(define-obsolete-function-alias 'company-intero 'intero-company)
956
957(defun intero-company-callback (source-buffer prefix-info cont)
958 "Generate completions for SOURCE-BUFFER based on PREFIX-INFO and call CONT on the results."
959 (cl-destructuring-bind
960 (beg end prefix type) prefix-info
961 (or (and (bound-and-true-p intero-mode)
962 (cl-case type
963 (haskell-completions-module-name-prefix
964 (intero-get-repl-completions source-buffer (concat "import " prefix) cont)
965 t)
966 (haskell-completions-identifier-prefix
967 (intero-get-completions source-buffer beg end cont)
968 t)
969 (haskell-completions-language-extension-prefix
970 (intero-get-repl-completions
971 source-buffer
972 (concat ":set -X" prefix)
973 (-partial (lambda (cont results)
974 (funcall cont
975 (mapcar (lambda (x)
976 (replace-regexp-in-string "^-X" "" x))
977 results)))
978 cont))
979 t)
980 (haskell-completions-pragma-name-prefix
981 (funcall cont
982 (cl-remove-if-not
983 (lambda (candidate)
984 (string-prefix-p prefix candidate))
985 intero-pragmas))
986 t)))
987 (intero-get-repl-completions source-buffer prefix cont))))
988
989(defun intero-completions-grab-prefix (&optional minlen)
990 "Grab prefix at point for possible completion.
991If specified, MINLEN is the shortest completion which will be
992considered."
993 (when (intero-completions-can-grab-prefix)
994 (let ((prefix (cond
995 ((intero-completions-grab-pragma-prefix))
996 ((intero-completions-grab-identifier-prefix)))))
997 (cond ((and minlen prefix)
998 (when (>= (length (nth 2 prefix)) minlen)
999 prefix))
1000 (prefix prefix)))))
1001
1002(defun intero-completions-can-grab-prefix ()
1003 "Check if the case is appropriate for grabbing completion prefix."
1004 (when (not (region-active-p))
1005 (when (looking-at-p (rx (| space line-end punct)))
1006 (when (not (bobp))
1007 (save-excursion
1008 (backward-char)
1009 (not (looking-at-p (rx (| space line-end)))))))))
1010
1011(defun intero-completions-grab-identifier-prefix ()
1012 "Grab identifier prefix."
1013 (let ((pos-at-point (intero-ident-pos-at-point))
1014 (p (point)))
1015 (when pos-at-point
1016 (let* ((start (car pos-at-point))
1017 (end (cdr pos-at-point))
1018 (type 'haskell-completions-identifier-prefix)
1019 (case-fold-search nil)
1020 value)
1021 (when (<= p end)
1022 (setq end p)
1023 (setq value (buffer-substring-no-properties start end))
1024 (when (string-match-p (rx bos upper) value)
1025 (save-excursion
1026 (goto-char (line-beginning-position))
1027 (when (re-search-forward
1028 (rx "import"
1029 (? (1+ space) "qualified")
1030 (1+ space)
1031 upper
1032 (1+ (| alnum ".")))
1033 p ;; bound
1034 t) ;; no-error
1035 (if (equal p (point))
1036 (setq type 'haskell-completions-module-name-prefix)
1037 (when (re-search-forward
1038 (rx (| " as " "("))
1039 start
1040 t)
1041 (setq type 'haskell-completions-identifier-prefix))))))
1042 (when (nth 8 (syntax-ppss))
1043 (setq type 'haskell-completions-general-prefix))
1044 (when value (list start end value type)))))))
1045
1046(defun intero-completions-grab-pragma-prefix ()
1047 "Grab completion prefix for pragma completions.
1048Returns a list of form '(prefix-start-position
1049prefix-end-position prefix-value prefix-type) for pramga names
1050such as WARNING, DEPRECATED, LANGUAGE etc. Also returns
1051completion prefixes for options in case OPTIONS_GHC pragma, or
1052language extensions in case of LANGUAGE pragma. Obsolete OPTIONS
1053pragma is supported also."
1054 (when (nth 4 (syntax-ppss))
1055 ;; We're inside comment
1056 (let ((p (point))
1057 (comment-start (nth 8 (syntax-ppss)))
1058 (case-fold-search nil)
1059 prefix-start
1060 prefix-end
1061 prefix-type
1062 prefix-value)
1063 (save-excursion
1064 (goto-char comment-start)
1065 (when (looking-at (rx "{-#" (1+ (| space "\n"))))
1066 (let ((pragma-start (match-end 0)))
1067 (when (> p pragma-start)
1068 ;; point stands after `{-#`
1069 (goto-char pragma-start)
1070 (when (looking-at (rx (1+ (| upper "_"))))
1071 ;; found suitable sequence for pragma name
1072 (let ((pragma-end (match-end 0))
1073 (pragma-value (match-string-no-properties 0)))
1074 (if (eq p pragma-end)
1075 ;; point is at the end of (in)complete pragma name
1076 ;; prepare resulting values
1077 (progn
1078 (setq prefix-start pragma-start)
1079 (setq prefix-end pragma-end)
1080 (setq prefix-value pragma-value)
1081 (setq prefix-type
1082 'haskell-completions-pragma-name-prefix))
1083 (when (and (> p pragma-end)
1084 (or (equal "OPTIONS_GHC" pragma-value)
1085 (equal "OPTIONS" pragma-value)
1086 (equal "LANGUAGE" pragma-value)))
1087 ;; point is after pragma name, so we need to check
1088 ;; special cases of `OPTIONS_GHC` and `LANGUAGE` pragmas
1089 ;; and provide a completion prefix for possible ghc
1090 ;; option or language extension.
1091 (goto-char pragma-end)
1092 (when (re-search-forward
1093 (rx (* anything)
1094 (1+ (regexp "\\S-")))
1095 p
1096 t)
1097 (let* ((str (match-string-no-properties 0))
1098 (split (split-string str (rx (| space "\n")) t))
1099 (val (car (last split)))
1100 (end (point)))
1101 (when (and (equal p end)
1102 (not (string-match-p "#" val)))
1103 (setq prefix-value val)
1104 (backward-char (length val))
1105 (setq prefix-start (point))
1106 (setq prefix-end end)
1107 (setq
1108 prefix-type
1109 (if (not (equal "LANGUAGE" pragma-value))
1110 'haskell-completions-ghc-option-prefix
1111 'haskell-completions-language-extension-prefix
1112 )))))))))))))
1113 (when prefix-value
1114 (list prefix-start prefix-end prefix-value prefix-type)))))
1115
1116;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1117;; Hole filling
1118
1119(defun intero-async-fill-at (buffer beg cont)
1120 "Make the blocking call to the process."
1121 (with-current-buffer buffer
1122 (intero-async-call
1123 'backend
1124 (format
1125 ":fill %s %d %d"
1126 (intero-path-for-ghci (intero-temp-file-name))
1127 (save-excursion (goto-char beg)
1128 (line-number-at-pos))
1129 (save-excursion (goto-char beg)
1130 (1+ (current-column))))
1131 (list :buffer (current-buffer) :cont cont)
1132 (lambda (state reply)
1133 (if (or (string-match "^Couldn't guess" reply)
1134 (string-match "^Unable to " reply)
1135 (intero-parse-error reply))
1136 (funcall (plist-get state :cont) (list))
1137 (with-current-buffer (plist-get state :buffer)
1138 (let ((candidates
1139 (split-string
1140 (replace-regexp-in-string
1141 "\n$" ""
1142 reply)
1143 "[\r\n]"
1144 t)))
1145 (when candidates
1146 (funcall (plist-get state :cont) candidates)))))))))
1147
1148(defun intero-grab-hole ()
1149 "When user is at a hole _ or _foo, return the starting point of
1150that hole."
1151 (let ((beg-end (intero-ident-pos-at-point)))
1152 (when beg-end
1153 (let ((string (buffer-substring-no-properties (car beg-end) (cdr beg-end))))
1154 (when (string-match-p "^_" string)
1155 beg-end)))))
1156
1157;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1158;; ELDoc integration
1159
1160(defvar-local intero-eldoc-cache (make-hash-table :test 'equal)
1161 "Cache for types of regions, used by `intero-eldoc'.
1162This is not for saving on requests (we make a request even if
1163something is in cache, overwriting the old entry), but rather for
1164making types show immediately when we do have them cached.")
1165
1166(defun intero-eldoc-maybe-print (msg)
1167 "Print MSG with eldoc if eldoc would display a message now.
1168Like `eldoc-print-current-symbol-info', but just printing MSG
1169instead of using `eldoc-documentation-function'."
1170 (with-demoted-errors "eldoc error: %s"
1171 (and (or (eldoc-display-message-p)
1172 ;; Erase the last message if we won't display a new one.
1173 (when eldoc-last-message
1174 (eldoc-message nil)
1175 nil))
1176 (eldoc-message msg))))
1177
1178(defun intero-eldoc ()
1179 "ELDoc backend for intero."
1180 (let ((buffer (intero-buffer 'backend)))
1181 (when (and buffer (process-live-p (get-buffer-process buffer)))
1182 (apply #'intero-get-type-at-async
1183 (lambda (beg end ty)
1184 (let ((response-status (intero-haskell-utils-repl-response-error-status ty)))
1185 (if (eq 'no-error response-status)
1186 (let ((msg (intero-fontify-expression
1187 (replace-regexp-in-string "[ \n]+" " " ty))))
1188 ;; Got an updated type-at-point, cache and print now:
1189 (puthash (list beg end)
1190 msg
1191 intero-eldoc-cache)
1192 (intero-eldoc-maybe-print msg))
1193 ;; But if we're seeing errors, invalidate cache-at-point:
1194 (remhash (list beg end) intero-eldoc-cache))))
1195 (intero-thing-at-point))))
1196 ;; If we have something cached at point, print that first:
1197 (gethash (intero-thing-at-point) intero-eldoc-cache))
1198
1199(defun intero-haskell-utils-repl-response-error-status (response)
1200 "Parse response REPL's RESPONSE for errors.
1201Returns one of the following symbols:
1202
1203+ unknown-command
1204+ option-missing
1205+ interactive-error
1206+ no-error
1207
1208*Warning*: this funciton covers only three kind of responses:
1209
1210* \"unknown command …\"
1211 REPL missing requested command
1212* \"<interactive>:3:5: …\"
1213 interactive REPL error
1214* \"Couldn't guess that module name. Does it exist?\"
1215 (:type-at and maybe some other commands error)
1216* *all other reposnses* are treated as success reposneses and
1217 'no-error is returned."
1218 (let ((first-line (car (split-string response "\n" t))))
1219 (cond
1220 ((null first-line) 'no-error)
1221 ((string-match-p "^unknown command" first-line)
1222 'unknown-command)
1223 ((string-match-p
1224 "^Couldn't guess that module name. Does it exist?"
1225 first-line)
1226 'option-missing)
1227 ((string-match-p "^<interactive>:" first-line)
1228 'interactive-error)
1229 ((string-match-p "^<no location info>:" first-line)
1230 'inspection-error)
1231 (t 'no-error))))
1232
1233;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1234;; REPL
1235
1236(defconst intero-prompt-regexp "^\4 ")
1237
1238(defvar-local intero-repl-previous-buffer nil
1239 "Records the buffer to which `intero-repl-switch-back' should jump.
1240This is set by `intero-repl-buffer', and should otherwise be nil.")
1241
1242(defun intero-repl-clear-buffer ()
1243 "Clear the current REPL buffer."
1244 (interactive)
1245 (let ((comint-buffer-maximum-size 0))
1246 (comint-truncate-buffer)))
1247
1248(defmacro intero-with-repl-buffer (prompt-options &rest body)
1249 "Evaluate given forms with the REPL as the current buffer.
1250The REPL will be started if necessary, and the REPL buffer will
1251be activated after evaluation. PROMPT-OPTIONS are passed to
1252`intero-repl-buffer'. BODY is the forms to be evaluated."
1253 (declare (indent defun))
1254 (let ((repl-buffer (cl-gensym)))
1255 `(let ((,repl-buffer (intero-repl-buffer ,prompt-options t)))
1256 (with-current-buffer ,repl-buffer
1257 ,@body)
1258 (when intero-pop-to-repl
1259 (pop-to-buffer ,repl-buffer)))))
1260
1261(defun intero-repl-after-load ()
1262 "Set the command to run after load."
1263 (interactive)
1264 (if (eq major-mode 'intero-repl-mode)
1265 (setq intero-repl-send-after-load
1266 (read-from-minibuffer
1267 "Command to run: "
1268 (or intero-repl-send-after-load
1269 (car (ring-elements comint-input-ring))
1270 "")))
1271 (error "Run this in the REPL.")))
1272
1273(defun intero-repl-load (&optional prompt-options)
1274 "Load the current file in the REPL.
1275If PROMPT-OPTIONS is non-nil, prompt with an options list."
1276 (interactive "P")
1277 (save-buffer)
1278 (let ((file (intero-path-for-ghci (intero-buffer-file-name))))
1279 (intero-with-repl-buffer prompt-options
1280 (comint-simple-send
1281 (get-buffer-process (current-buffer))
1282 ":set prompt \"\\n\"")
1283 (if (or (not intero-repl-last-loaded)
1284 (not (equal file intero-repl-last-loaded)))
1285 (progn
1286 (comint-simple-send
1287 (get-buffer-process (current-buffer))
1288 (concat ":load " file))
1289 (setq intero-repl-last-loaded file))
1290 (comint-simple-send
1291 (get-buffer-process (current-buffer))
1292 ":reload"))
1293 (when intero-repl-send-after-load
1294 (comint-simple-send
1295 (get-buffer-process (current-buffer))
1296 intero-repl-send-after-load))
1297 (comint-simple-send (get-buffer-process (current-buffer))
1298 ":set prompt \"\\4 \""))))
1299
1300(defun intero-repl-eval-region (begin end &optional prompt-options)
1301 "Evaluate the code in region from BEGIN to END in the REPL.
1302If the region is unset, the current line will be used.
1303PROMPT-OPTIONS are passed to `intero-repl-buffer' if supplied."
1304 (interactive "r")
1305 (unless (use-region-p)
1306 (setq begin (line-beginning-position)
1307 end (line-end-position)))
1308 (let ((text (buffer-substring-no-properties begin end)))
1309 (intero-with-repl-buffer prompt-options
1310 (comint-simple-send
1311 (get-buffer-process (current-buffer))
1312 text))))
1313
1314(defun intero-repl (&optional prompt-options)
1315 "Start up the REPL for this stack project.
1316If PROMPT-OPTIONS is non-nil, prompt with an options list."
1317 (interactive "P")
1318 (switch-to-buffer-other-window (intero-repl-buffer prompt-options t)))
1319
1320(defun intero-repl-restart ()
1321 "Restart the REPL."
1322 (interactive)
1323 (let* ((root (intero-project-root))
1324 (package-name (intero-package-name))
1325 (backend-buffer (intero-buffer 'backend))
1326 (name (format "*intero:%s:%s:repl*"
1327 (file-name-nondirectory root)
1328 package-name)))
1329 (when (get-buffer name)
1330 (with-current-buffer (get-buffer name)
1331 (goto-char (point-max))
1332 (let ((process (get-buffer-process (current-buffer))))
1333 (when process (kill-process process)))
1334 (intero-repl-mode-start backend-buffer
1335 (buffer-local-value 'intero-targets backend-buffer)
1336 nil
1337 (buffer-local-value 'intero-stack-yaml backend-buffer))))))
1338
1339(defun intero-repl-buffer (prompt-options &optional store-previous)
1340 "Start the REPL buffer.
1341If PROMPT-OPTIONS is non-nil, prompt with an options list. When
1342STORE-PREVIOUS is non-nil, note the caller's buffer in
1343`intero-repl-previous-buffer'."
1344 (let* ((root (intero-project-root))
1345 (package-name (intero-package-name))
1346 (name (format "*intero:%s:%s:repl*"
1347 (file-name-nondirectory root)
1348 package-name))
1349 (initial-buffer (current-buffer))
1350 (backend-buffer (intero-buffer 'backend)))
1351 (with-current-buffer
1352 (or (let ((buf (get-buffer name)))
1353 (and (get-buffer-process buf)
1354 buf))
1355 (with-current-buffer
1356 (get-buffer-create name)
1357 ;; The new buffer doesn't know if the initial buffer was hosted
1358 ;; remotely or not, so we need to extend by the host of the
1359 ;; initial buffer to cd. We could also achieve this by setting the
1360 ;; buffer's intero-buffer-host, but intero-repl-mode wipes this, so
1361 ;; we defer setting that until after.
1362 (cd (intero-extend-path-by-buffer-host root initial-buffer))
1363 (intero-repl-mode) ; wipes buffer-local variables
1364 (intero-inherit-local-variables initial-buffer)
1365 (setq intero-buffer-host (intero-buffer-host initial-buffer))
1366 (intero-repl-mode-start backend-buffer
1367 (buffer-local-value 'intero-targets backend-buffer)
1368 prompt-options
1369 (buffer-local-value 'intero-stack-yaml backend-buffer))
1370 (current-buffer)))
1371 (progn
1372 (when store-previous
1373 (setq intero-repl-previous-buffer initial-buffer))
1374 (current-buffer)))))
1375
1376(defvar intero-hyperlink-map
1377 (let ((map (make-sparse-keymap)))
1378 (define-key map [mouse-1] 'intero-find-file-with-line-and-char)
1379 (define-key map [C-return] 'intero-find-file-with-line-and-char)
1380 map)
1381 "Keymap for clicking on links in REPL.")
1382
1383(define-derived-mode intero-repl-mode comint-mode "Intero-REPL"
1384 "Interactive prompt for Intero."
1385 (when (and (not (eq major-mode 'fundamental-mode))
1386 (eq this-command 'intero-repl-mode))
1387 (error "You probably meant to run: M-x intero-repl"))
1388 (setq-local comint-prompt-regexp intero-prompt-regexp)
1389 (setq-local warning-suppress-types (cons '(undo discard-info) warning-suppress-types))
1390 (setq-local comint-prompt-read-only t)
1391 (add-hook 'completion-at-point-functions 'intero-repl-completion-at-point nil t)
1392 (company-mode))
1393
1394(defun intero-repl-mode-start (backend-buffer targets prompt-options stack-yaml)
1395 "Start the process for the repl in the current buffer.
1396BACKEND-BUFFER is used for options. TARGETS is the targets to
1397load. If PROMPT-OPTIONS is non-nil, prompt with an options list.
1398STACK-YAML is the stack yaml config to use. When nil, tries to
1399use project-wide intero-stack-yaml when nil, otherwise uses
1400stack's default)."
1401 (setq intero-targets targets)
1402 (setq intero-repl-last-loaded nil)
1403 (when stack-yaml
1404 (setq intero-stack-yaml stack-yaml))
1405 (when prompt-options
1406 (intero-repl-options backend-buffer))
1407 (let ((stack-yaml (if stack-yaml
1408 stack-yaml
1409 (buffer-local-value 'intero-stack-yaml backend-buffer)))
1410 (arguments (intero-make-options-list
1411 "ghci"
1412 (or targets
1413 (let ((package-name (buffer-local-value 'intero-package-name
1414 backend-buffer)))
1415 (unless (equal "" package-name)
1416 (list package-name))))
1417 (buffer-local-value 'intero-repl-no-build backend-buffer)
1418 (buffer-local-value 'intero-repl-no-load backend-buffer)
1419 nil
1420 stack-yaml)))
1421 (insert (propertize
1422 (format "Starting:\n %s ghci %s\n" intero-stack-executable
1423 (combine-and-quote-strings arguments))
1424 'face 'font-lock-comment-face))
1425 (let* ((script-buffer
1426 (with-current-buffer (find-file-noselect (intero-make-temp-file "intero-script"))
1427 ;; Commented out this line due to this bug:
1428 ;; https://github.com/chrisdone/intero/issues/569
1429 ;; GHC 8.4.3 has some bug causing a panic on GHCi.
1430 ;; :set -fdefer-type-errors
1431 (insert ":set prompt \"\"
1432:set -fbyte-code
1433:set -fdiagnostics-color=never
1434:set prompt \"\\4 \"
1435")
1436 (basic-save-buffer)
1437 (current-buffer)))
1438 (script
1439 (with-current-buffer script-buffer
1440 (intero-localize-path (intero-buffer-file-name)))))
1441 (let ((process
1442 (get-buffer-process
1443 (apply #'make-comint-in-buffer "intero" (current-buffer) intero-stack-executable nil "ghci"
1444 (append arguments
1445 (list "--verbosity" "silent")
1446 (list "--ghci-options"
1447 (concat "-ghci-script=" script))
1448 (cl-mapcan (lambda (x) (list "--ghci-options" x)) intero-extra-ghci-options))))))
1449 (when (process-live-p process)
1450 (set-process-query-on-exit-flag process nil)
1451 (message "Started Intero process for REPL.")
1452 (kill-buffer script-buffer))))))
1453
1454(defun intero-repl-options (backend-buffer)
1455 "Open an option menu to set options used when starting the REPL.
1456Default options come from user customization and any temporary
1457changes in the BACKEND-BUFFER."
1458 (interactive)
1459 (let* ((old-options
1460 (list
1461 (list :key "load-all"
1462 :title "Load all modules"
1463 :default (not (buffer-local-value 'intero-repl-no-load backend-buffer)))
1464 (list :key "build-first"
1465 :title "Build project first"
1466 :default (not (buffer-local-value 'intero-repl-no-build backend-buffer)))))
1467 (new-options (intero-multiswitch "Start REPL with options:" old-options)))
1468 (with-current-buffer backend-buffer
1469 (setq-local intero-repl-no-load (not (member "load-all" new-options)))
1470 (setq-local intero-repl-no-build (not (member "build-first" new-options))))))
1471
1472(font-lock-add-keywords
1473 'intero-repl-mode
1474 '(("\\(\4\\)"
1475 (0 (prog1 ()
1476 (compose-region (match-beginning 1)
1477 (match-end 1)
1478 ?λ))))))
1479
1480(define-key intero-repl-mode-map [remap move-beginning-of-line] 'intero-repl-beginning-of-line)
1481(define-key intero-repl-mode-map [remap delete-backward-char] 'intero-repl-delete-backward-char)
1482(define-key intero-repl-mode-map (kbd "C-c C-k") 'intero-repl-clear-buffer)
1483(define-key intero-repl-mode-map (kbd "C-c C-z") 'intero-repl-switch-back)
1484
1485(defun intero-repl-delete-backward-char ()
1486 "Delete backwards, excluding the prompt."
1487 (interactive)
1488 (unless (looking-back intero-prompt-regexp (line-beginning-position))
1489 (call-interactively 'delete-backward-char)))
1490
1491(defun intero-repl-beginning-of-line ()
1492 "Go to the beginning of the line, excluding the prompt."
1493 (interactive)
1494 (if (search-backward-regexp intero-prompt-regexp (line-beginning-position) t 1)
1495 (goto-char (+ 2 (line-beginning-position)))
1496 (call-interactively 'move-beginning-of-line)))
1497
1498(defun intero-repl-switch-back ()
1499 "Switch back to the buffer from which this REPL buffer was reached."
1500 (interactive)
1501 (if intero-repl-previous-buffer
1502 (switch-to-buffer-other-window intero-repl-previous-buffer)
1503 (message "No previous buffer.")))
1504
1505;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1506;; Buffer operations
1507
1508(defun intero-thing-at-point ()
1509 "Return (list START END) of something at the point."
1510 (if (region-active-p)
1511 (list (region-beginning)
1512 (region-end))
1513 (let ((pos (intero-ident-pos-at-point)))
1514 (if pos
1515 (list (car pos) (cdr pos))
1516 (list (point) (point))))))
1517
1518(defun intero-ident-at-point ()
1519 "Return the identifier under point, or nil if none found.
1520May return a qualified name."
1521 (let ((reg (intero-ident-pos-at-point)))
1522 (when reg
1523 (buffer-substring-no-properties (car reg) (cdr reg)))))
1524
1525(defun intero-ident-pos-at-point ()
1526 "Return the span of the identifier near point going backward.
1527Returns nil if no identifier found or point is inside string or
1528comment. May return a qualified name."
1529 (when (not (nth 8 (syntax-ppss)))
1530 ;; Do not handle comments and strings
1531 (let (start end)
1532 ;; Initial point position is non-deterministic, it may occur anywhere
1533 ;; inside identifier span, so the approach is:
1534 ;; - first try go left and find left boundary
1535 ;; - then try go right and find right boundary
1536 ;;
1537 ;; In both cases assume the longest path, e.g. when going left take into
1538 ;; account than point may occur at the end of identifier, when going right
1539 ;; take into account that point may occur at the beginning of identifier.
1540 ;;
1541 ;; We should handle `.` character very careful because it is heavily
1542 ;; overloaded. Examples of possible cases:
1543 ;; Control.Monad.>>= -- delimiter
1544 ;; Control.Monad.when -- delimiter
1545 ;; Data.Aeson..: -- delimiter and operator symbol
1546 ;; concat.map -- composition function
1547 ;; .? -- operator symbol
1548 (save-excursion
1549 ;; First, skip whitespace if we're on it, moving point to last
1550 ;; identifier char. That way, if we're at "map ", we'll see the word
1551 ;; "map".
1552 (when (and (looking-at-p (rx eol))
1553 (not (bolp)))
1554 (backward-char))
1555 (when (and (not (eobp))
1556 (eq (char-syntax (char-after)) ? ))
1557 (skip-chars-backward " \t")
1558 (backward-char))
1559 ;; Now let's try to go left.
1560 (save-excursion
1561 (if (not (intero-mode--looking-at-varsym))
1562 ;; Looking at non-operator char, this is quite simple
1563 (progn
1564 (skip-syntax-backward "w_")
1565 ;; Remember position
1566 (setq start (point)))
1567 ;; Looking at operator char.
1568 (while (and (not (bobp))
1569 (intero-mode--looking-at-varsym))
1570 ;; skip all operator chars backward
1571 (setq start (point))
1572 (backward-char))
1573 ;; Extra check for case when reached beginning of the buffer.
1574 (when (intero-mode--looking-at-varsym)
1575 (setq start (point))))
1576 ;; Slurp qualification part if present. If identifier is qualified in
1577 ;; case of non-operator point will stop before `.` dot, but in case of
1578 ;; operator it will stand at `.` delimiting dot. So if we're looking
1579 ;; at `.` let's step one char forward and try to get qualification
1580 ;; part.
1581 (goto-char start)
1582 (when (looking-at-p (rx "."))
1583 (forward-char))
1584 (let ((pos (intero-mode--skip-qualification-backward)))
1585 (when pos
1586 (setq start pos))))
1587 ;; Finally, let's try to go right.
1588 (save-excursion
1589 ;; Try to slurp qualification part first.
1590 (skip-syntax-forward "w_")
1591 (setq end (point))
1592 (while (and (looking-at-p (rx "." upper))
1593 (not (zerop (progn (forward-char)
1594 (skip-syntax-forward "w_")))))
1595 (setq end (point)))
1596 ;; If point was at non-operator we already done, otherwise we need an
1597 ;; extra check.
1598 (while (intero-mode--looking-at-varsym)
1599 (forward-char)
1600 (setq end (point))))
1601 (when (not (= start end))
1602 (cons start end))))))
1603
1604(defun intero-mode--looking-at-varsym ()
1605 "Return t when point stands at operator symbol."
1606 (when (not (eobp))
1607 (let ((lex (intero-lexeme-classify-by-first-char (char-after))))
1608 (or (eq lex 'varsym)
1609 (eq lex 'consym)))))
1610
1611(defun intero-mode--skip-qualification-backward ()
1612 "Skip qualified part of identifier backward.
1613Expects point stands *after* delimiting dot.
1614Returns beginning position of qualified part or nil if no qualified part found."
1615 (when (not (and (bobp)
1616 (looking-at-p (rx bol))))
1617 (let ((case-fold-search nil)
1618 pos)
1619 (while (and (eq (char-before) ?.)
1620 (progn (backward-char)
1621 (not (zerop (skip-syntax-backward "w'"))))
1622 (skip-syntax-forward "'")
1623 (looking-at-p "[[:upper:]]"))
1624 (setq pos (point)))
1625 pos)))
1626
1627(defun intero-lexeme-classify-by-first-char (char)
1628 "Classify token by CHAR.
1629CHAR is a chararacter that is assumed to be the first character
1630of a token."
1631 (let ((category (get-char-code-property char 'general-category)))
1632
1633 (cond
1634 ((or (member char '(?! ?# ?$ ?% ?& ?* ?+ ?. ?/ ?< ?= ?> ?? ?@ ?^ ?| ?~ ?\\ ?-))
1635 (and (> char 127)
1636 (member category '(Pc Pd Po Sm Sc Sk So))))
1637 'varsym)
1638 ((equal char ?:)
1639 'consym)
1640 ((equal char ?\')
1641 'char)
1642 ((equal char ?\")
1643 'string)
1644 ((member category '(Lu Lt))
1645 'conid)
1646 ((or (equal char ?_)
1647 (member category '(Ll Lo)))
1648 'varid)
1649 ((and (>= char ?0) (<= char ?9))
1650 'number)
1651 ((member char '(?\] ?\[ ?\( ?\) ?\{ ?\} ?\` ?\, ?\;))
1652 'special))))
1653
1654(defun intero-buffer-file-name (&optional buffer)
1655 "Call function `buffer-file-name' for BUFFER and clean its result.
1656The path returned is canonicalized and stripped of any text properties."
1657 (let ((name (buffer-file-name buffer)))
1658 (when name
1659 (intero-canonicalize-path (substring-no-properties name)))))
1660
1661(defun intero-paths-for-same-file (path-1 path-2)
1662 "Compare PATH-1 and PATH-2 to see if they represent the same file."
1663 (let ((simplify-path #'(lambda (path)
1664 (if (tramp-tramp-file-p path)
1665 (let* ((dissection (tramp-dissect-file-name path))
1666 (host (tramp-file-name-host dissection))
1667 (localname (tramp-file-name-localname dissection)))
1668 (concat host ":" localname))
1669 (expand-file-name path)))))
1670 (string= (funcall simplify-path path-1) (funcall simplify-path path-2))))
1671
1672(defun intero-buffer-host (&optional buffer)
1673 "Get the hostname of the box hosting the file behind the BUFFER."
1674 (with-current-buffer (or buffer (current-buffer))
1675 (let ((file (intero-buffer-file-name)))
1676 (if intero-buffer-host
1677 intero-buffer-host
1678 (setq intero-buffer-host
1679 (when file
1680 (if (tramp-tramp-file-p file)
1681 (tramp-file-name-host (tramp-dissect-file-name file))
1682 "")))))))
1683
1684(defun intero-extend-path-by-buffer-host (path &optional buffer)
1685 "Take a PATH, and extend it by the host of the provided BUFFER (default to current buffer). Return PATH unchanged if the file is local, or the BUFFER has no host."
1686 (with-current-buffer (or buffer (current-buffer))
1687 (if (or (eq nil (intero-buffer-host)) (eq "" (intero-buffer-host)))
1688 path
1689 (expand-file-name
1690 (concat "/"
1691 (intero-buffer-host)
1692 ":"
1693 path)))))
1694
1695(defvar-local intero-temp-file-name nil
1696 "The name of a temporary file to which the current buffer's content is copied.")
1697
1698(defun intero-temp-file-p (path)
1699 "Is PATH a temp file?"
1700 (string= (file-name-directory path)
1701 (file-name-directory (intero-temp-file-dir))))
1702
1703(defun intero-temp-file-origin-buffer (temp-file)
1704 "Get the original buffer that TEMP-FILE was created for."
1705 (or
1706 (gethash (intero-canonicalize-path temp-file)
1707 intero-temp-file-buffer-mapping)
1708 (cl-loop
1709 for buffer in (buffer-list)
1710 when (string= (intero-canonicalize-path temp-file)
1711 (buffer-local-value 'intero-temp-file-name buffer))
1712 return buffer)))
1713
1714(defun intero-unmangle-file-path (file)
1715 "If FILE is an intero temp file, return the original source path, otherwise FILE."
1716 (or (when (intero-temp-file-p file)
1717 (let ((origin-buffer (intero-temp-file-origin-buffer file)))
1718 (when origin-buffer
1719 (buffer-file-name origin-buffer))))
1720 file))
1721
1722(defun intero-make-temp-file (prefix &optional dir-flag suffix)
1723 "Like `make-temp-file', but using a different temp directory.
1724PREFIX, DIR-FLAG and SUFFIX are all passed to `make-temp-file'
1725unmodified. A different directory is applied so that if docker
1726is used with stack, the commands run inside docker can find the
1727path."
1728 (let ((temporary-file-directory
1729 (intero-temp-file-dir)))
1730 (make-directory temporary-file-directory t)
1731 (make-temp-file prefix dir-flag suffix)))
1732
1733(defun intero-temp-file-dir ()
1734 "Get the temporary file directory for the current intero project."
1735 (let* ((intero-absolute-project-root
1736 (intero-extend-path-by-buffer-host (intero-project-root)))
1737 (temporary-file-directory
1738 (expand-file-name ".stack-work/intero/"
1739 intero-absolute-project-root)))
1740 temporary-file-directory))
1741
1742(defun intero-temp-file-name (&optional buffer)
1743 "Return the name of a temp file pertaining to BUFFER."
1744 (with-current-buffer (or buffer (current-buffer))
1745 (or intero-temp-file-name
1746 (progn (setq intero-temp-file-name
1747 (intero-canonicalize-path
1748 (intero-make-temp-file
1749 "intero" nil
1750 (concat "-TEMP." (if (buffer-file-name)
1751 (file-name-extension (buffer-file-name))
1752 "hs")))))
1753 (puthash intero-temp-file-name
1754 (current-buffer)
1755 intero-temp-file-buffer-mapping)
1756 intero-temp-file-name))))
1757
1758(defun intero-staging-file-name (&optional buffer)
1759 "Return the name of a temp file containing an up-to-date copy of BUFFER's contents."
1760 (with-current-buffer (or buffer (current-buffer))
1761 (let* ((contents (buffer-string))
1762 (fname (intero-canonicalize-path
1763 (intero-make-temp-file
1764 "intero" nil
1765 (concat "-STAGING." (if (buffer-file-name)
1766 (file-name-extension (buffer-file-name))
1767 "hs"))))))
1768 (with-temp-file fname
1769 (insert contents))
1770 fname)))
1771
1772(defun intero-quote-path-for-ghci (path)
1773 "Quote PATH as necessary so that it can be passed to a GHCi :command."
1774 (concat "\"" (replace-regexp-in-string "\\([\\\"]\\)" "\\\\\\1" path nil nil) "\""))
1775
1776(defun intero-path-for-ghci (path)
1777 "Turn a possibly-remote PATH into one that can be passed to a GHCi :command."
1778 (intero-quote-path-for-ghci (intero-localize-path path)))
1779
1780(defun intero-localize-path (path)
1781 "Turn a possibly-remote PATH to a purely local one.
1782This is used to create paths which a remote intero process can load."
1783 (if (tramp-tramp-file-p path)
1784 (tramp-file-name-localname (tramp-dissect-file-name path))
1785 path))
1786
1787(defun intero-canonicalize-path (path)
1788 "Return a standardized version of PATH.
1789Path names are standardised and drive names are
1790capitalized (relevant on Windows)."
1791 (intero-capitalize-drive-letter (convert-standard-filename path)))
1792
1793(defun intero-capitalize-drive-letter (path)
1794 "Ensures the drive letter is capitalized in PATH.
1795This applies to paths of the form
1796x:\\foo\\bar (i.e., Windows)."
1797 (save-match-data
1798 (let ((drive-path (split-string path ":\\\\")))
1799 (if (or (null (car drive-path)) (null (cdr drive-path)))
1800 path
1801 (concat (upcase (car drive-path)) ":\\" (cadr drive-path))))))
1802
1803;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1804;; Query/commands
1805
1806(defun intero-get-all-types ()
1807 "Get all types in all expressions in all modules."
1808 (intero-blocking-network-call 'backend ":all-types"))
1809
1810(defun intero-get-type-at (beg end)
1811 "Get the type at the given region denoted by BEG and END."
1812 (let ((result (intero-get-type-at-helper beg end)))
1813 (if (string-match (regexp-quote "Couldn't guess that module name. Does it exist?")
1814 result)
1815 (progn (flycheck-buffer)
1816 (message "No type information yet, compiling module ...")
1817 (intero-get-type-at-helper-process beg end))
1818 result)))
1819
1820(defun intero-get-type-at-helper (beg end)
1821 (replace-regexp-in-string
1822 "\n$" ""
1823 (intero-blocking-network-call
1824 'backend
1825 (intero-format-get-type-at beg end))))
1826
1827(defun intero-get-type-at-helper-process (beg end)
1828 (replace-regexp-in-string
1829 "\n$" ""
1830 (intero-blocking-call
1831 'backend
1832 (intero-format-get-type-at beg end))))
1833
1834(defun intero-get-type-at-async (cont beg end)
1835 "Call CONT with type of the region denoted by BEG and END.
1836CONT is called within the current buffer, with BEG, END and the
1837type as arguments."
1838 (intero-async-network-call
1839 'backend
1840 (intero-format-get-type-at beg end)
1841 (list :cont cont
1842 :source-buffer (current-buffer)
1843 :beg beg
1844 :end end)
1845 (lambda (state reply)
1846 (with-current-buffer (plist-get state :source-buffer)
1847 (funcall (plist-get state :cont)
1848 (plist-get state :beg)
1849 (plist-get state :end)
1850 (replace-regexp-in-string "\n$" "" reply))))))
1851
1852(defun intero-format-get-type-at (beg end)
1853 "Compose a request for getting types in region from BEG to END."
1854 (format ":type-at %s %d %d %d %d %S"
1855 (intero-path-for-ghci (intero-temp-file-name))
1856 (save-excursion (goto-char beg)
1857 (line-number-at-pos))
1858 (save-excursion (goto-char beg)
1859 (1+ (current-column)))
1860 (save-excursion (goto-char end)
1861 (line-number-at-pos))
1862 (save-excursion (goto-char end)
1863 (1+ (current-column)))
1864 (buffer-substring-no-properties beg end)))
1865
1866(defun intero-get-info-of (thing)
1867 "Get info for THING."
1868 (let ((optimistic-result
1869 (replace-regexp-in-string
1870 "\n$" ""
1871 (intero-blocking-call
1872 'backend
1873 (format ":info %s" thing)))))
1874 (if (string-match-p "^<interactive>" optimistic-result)
1875 ;; Load the module Interpreted so that we get information,
1876 ;; then restore bytecode.
1877 (progn (intero-async-call
1878 'backend
1879 ":set -fbyte-code")
1880 (set-buffer-modified-p t)
1881 (save-buffer)
1882 (unless (member 'save flycheck-check-syntax-automatically)
1883 (intero-async-call
1884 'backend
1885 (concat ":load " (intero-path-for-ghci (intero-temp-file-name)))))
1886 (intero-async-call
1887 'backend
1888 ":set -fobject-code")
1889 (replace-regexp-in-string
1890 "\n$" ""
1891 (intero-blocking-call
1892 'backend
1893 (format ":info %s" thing))))
1894 optimistic-result)))
1895
1896(defconst intero-unloaded-module-string "Couldn't guess that module name. Does it exist?")
1897
1898(defun intero-get-loc-at (beg end)
1899 "Get the location of the identifier denoted by BEG and END."
1900 (let ((result (intero-get-loc-at-helper beg end)))
1901 (if (string-match (regexp-quote intero-unloaded-module-string)
1902 result)
1903 (progn (flycheck-buffer)
1904 (message "No location information yet, compiling module ...")
1905 (intero-get-loc-at-helper-process beg end))
1906 result)))
1907
1908(defun intero-get-loc-at-helper (beg end)
1909 "Make the blocking call to the process."
1910 (replace-regexp-in-string
1911 "\n$" ""
1912 (intero-blocking-network-call
1913 'backend
1914 (format ":loc-at %s %d %d %d %d %S"
1915 (intero-path-for-ghci (intero-temp-file-name))
1916 (save-excursion (goto-char beg)
1917 (line-number-at-pos))
1918 (save-excursion (goto-char beg)
1919 (1+ (current-column)))
1920 (save-excursion (goto-char end)
1921 (line-number-at-pos))
1922 (save-excursion (goto-char end)
1923 (1+ (current-column)))
1924 (buffer-substring-no-properties beg end)))))
1925
1926(defun intero-get-loc-at-helper-process (beg end)
1927 "Make the blocking call to the process."
1928 (replace-regexp-in-string
1929 "\n$" ""
1930 (intero-blocking-call
1931 'backend
1932 (format ":loc-at %s %d %d %d %d %S"
1933 (intero-path-for-ghci (intero-temp-file-name))
1934 (save-excursion (goto-char beg)
1935 (line-number-at-pos))
1936 (save-excursion (goto-char beg)
1937 (1+ (current-column)))
1938 (save-excursion (goto-char end)
1939 (line-number-at-pos))
1940 (save-excursion (goto-char end)
1941 (1+ (current-column)))
1942 (buffer-substring-no-properties beg end)))))
1943
1944(defun intero-get-uses-at (beg end)
1945 "Return usage list for identifier denoted by BEG and END."
1946 (let ((result (intero-get-uses-at-helper beg end)))
1947 (if (string-match (regexp-quote intero-unloaded-module-string)
1948 result)
1949 (progn (flycheck-buffer)
1950 (message "No use information yet, compiling module ...")
1951 (intero-get-uses-at-helper-process beg end))
1952 result)))
1953
1954(defun intero-get-uses-at-helper (beg end)
1955 "Return usage list for identifier denoted by BEG and END."
1956 (replace-regexp-in-string
1957 "\n$" ""
1958 (intero-blocking-network-call
1959 'backend
1960 (format ":uses %s %d %d %d %d %S"
1961 (intero-path-for-ghci (intero-temp-file-name))
1962 (save-excursion (goto-char beg)
1963 (line-number-at-pos))
1964 (save-excursion (goto-char beg)
1965 (1+ (current-column)))
1966 (save-excursion (goto-char end)
1967 (line-number-at-pos))
1968 (save-excursion (goto-char end)
1969 (1+ (current-column)))
1970 (buffer-substring-no-properties beg end)))))
1971
1972(defun intero-get-uses-at-helper-process (beg end)
1973 "Return usage list for identifier denoted by BEG and END."
1974 (replace-regexp-in-string
1975 "\n$" ""
1976 (intero-blocking-call
1977 'backend
1978 (format ":uses %s %d %d %d %d %S"
1979 (intero-path-for-ghci (intero-temp-file-name))
1980 (save-excursion (goto-char beg)
1981 (line-number-at-pos))
1982 (save-excursion (goto-char beg)
1983 (1+ (current-column)))
1984 (save-excursion (goto-char end)
1985 (line-number-at-pos))
1986 (save-excursion (goto-char end)
1987 (1+ (current-column)))
1988 (buffer-substring-no-properties beg end)))))
1989
1990(defun intero-get-completions (source-buffer beg end cont)
1991 "Get completions and send to SOURCE-BUFFER.
1992Prefix is marked by positions BEG and END. Completions are
1993passed to CONT in SOURCE-BUFFER."
1994 (intero-async-network-call
1995 'backend
1996 (format ":complete-at %s %d %d %d %d %S"
1997 (intero-path-for-ghci (intero-temp-file-name))
1998 (save-excursion (goto-char beg)
1999 (line-number-at-pos))
2000 (save-excursion (goto-char beg)
2001 (1+ (current-column)))
2002 (save-excursion (goto-char end)
2003 (line-number-at-pos))
2004 (save-excursion (goto-char end)
2005 (1+ (current-column)))
2006 (buffer-substring-no-properties beg end))
2007 (list :cont cont :source-buffer source-buffer)
2008 (lambda (state reply)
2009 (with-current-buffer
2010 (plist-get state :source-buffer)
2011 (funcall
2012 (plist-get state :cont)
2013 (intero-completion-response-to-list reply))))))
2014
2015(defun intero-completion-response-to-list (reply)
2016 "Convert the REPLY from a backend completion to a list."
2017 (if (string-match-p "^*** Exception" reply)
2018 (list)
2019 (mapcar
2020 (lambda (x)
2021 (replace-regexp-in-string "\\\"" "" x))
2022 (split-string reply "\n" t))))
2023
2024(defun intero-get-repl-completions (source-buffer prefix cont)
2025 "Get REPL completions and send to SOURCE-BUFFER.
2026Completions for PREFIX are passed to CONT in SOURCE-BUFFER."
2027 (intero-async-call
2028 'backend
2029 (format ":complete repl %S" prefix)
2030 (list :cont cont :source-buffer source-buffer)
2031 (lambda (state reply)
2032 (with-current-buffer
2033 (plist-get state :source-buffer)
2034 (funcall
2035 (plist-get state :cont)
2036 (mapcar
2037 (lambda (x)
2038 (replace-regexp-in-string "\\\"" "" x))
2039 (cdr (split-string reply "\n" t))))))))
2040
2041;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2042;; Process communication
2043
2044(defun intero-call-process (program &optional infile destination display &rest args)
2045 "Synchronously call PROGRAM.
2046INFILE, DESTINATION, DISPLAY and ARGS are as for
2047'call-process'/'process-file'. Provides TRAMP compatibility for
2048'call-process'; when the 'default-directory' is on a remote
2049machine, PROGRAM is launched on that machine."
2050 (let ((process-args (append (list program infile destination display) args)))
2051 (apply 'process-file process-args)))
2052
2053(defun intero-call-stack (&optional infile destination display stack-yaml &rest args)
2054 "Synchronously call stack using the same arguments as `intero-call-process'.
2055INFILE, DESTINATION, DISPLAY and ARGS are as for
2056`call-process'/`process-file'. STACK-YAML specifies which stack
2057yaml config to use, or stack's default when nil."
2058 (let ((stack-yaml-args (when stack-yaml
2059 (list "--stack-yaml" stack-yaml))))
2060 (apply #'intero-call-process intero-stack-executable
2061 infile destination display
2062 (append stack-yaml-args args))))
2063
2064(defun intero-delete-worker (worker)
2065 "Delete the given WORKER."
2066 (when (intero-buffer-p worker)
2067 (with-current-buffer (intero-get-buffer-create worker)
2068 (when (get-buffer-process (current-buffer))
2069 (setq intero-deleting t)
2070 (kill-process (get-buffer-process (current-buffer)))
2071 (delete-process (get-buffer-process (current-buffer))))
2072 (kill-buffer (current-buffer)))))
2073
2074(defun intero-blocking-call (worker cmd)
2075 "Send WORKER the command string CMD and block pending its result."
2076 (let ((result (list nil)))
2077 (intero-async-call
2078 worker
2079 cmd
2080 result
2081 (lambda (result reply)
2082 (setf (car result) reply)))
2083 (let ((buffer (intero-buffer worker)))
2084 (while (not (null (buffer-local-value 'intero-callbacks buffer)))
2085 (sleep-for 0.0001)))
2086 (car result)))
2087
2088(defun intero-blocking-network-call (worker cmd)
2089 "Send WORKER the command string CMD via the network and block pending its result."
2090 (let ((result (list nil)))
2091 (intero-async-network-call
2092 worker
2093 cmd
2094 result
2095 (lambda (result reply)
2096 (setf (car result) reply)))
2097 (while (eq (car result) nil)
2098 (sleep-for 0.0001))
2099 (car result)))
2100
2101(defun intero-async-network-call (worker cmd &optional state callback)
2102 "Send WORKER the command string CMD, via a network connection.
2103The result, along with the given STATE, is passed to CALLBACK
2104as (CALLBACK STATE REPLY)."
2105 (if (file-remote-p default-directory)
2106 (intero-async-call worker cmd state callback)
2107 (let ((buffer (intero-buffer worker)))
2108 (if (and buffer (process-live-p (get-buffer-process buffer)))
2109 (with-current-buffer buffer
2110 (if intero-service-port
2111 (let* ((buffer (generate-new-buffer (format " intero-network:%S" worker)))
2112 (process
2113 (make-network-process
2114 :name (format "%S" worker)
2115 :buffer buffer
2116 :host 'local
2117 :service intero-service-port
2118 :family 'ipv4
2119 :nowait t
2120 :noquery t
2121 :sentinel 'intero-network-call-sentinel)))
2122 (with-current-buffer buffer
2123 (setq intero-async-network-cmd cmd)
2124 (setq intero-async-network-state state)
2125 (setq intero-async-network-worker worker)
2126 (setq intero-async-network-callback callback)))
2127 (progn (when intero-debug (message "No `intero-service-port', falling back ..."))
2128 (intero-async-call worker cmd state callback))))
2129 (error "Intero process is not running: run M-x intero-restart to start it")))))
2130
2131(defun intero-network-call-sentinel (process event)
2132 (pcase event
2133 ;; This event sometimes gets sent when (delete-process) is called, but
2134 ;; inconsistently. We can't rely on it for killing buffers, but we need to
2135 ;; handle the possibility.
2136 ("deleted\n")
2137
2138 ("open\n"
2139 (with-current-buffer (process-buffer process)
2140 (when intero-debug (message "Connected to service, sending %S" intero-async-network-cmd))
2141 (setq intero-async-network-connected t)
2142 (if intero-async-network-cmd
2143 (process-send-string process (concat intero-async-network-cmd "\n"))
2144 (delete-process process)
2145 (kill-buffer (process-buffer process)))))
2146 (_
2147 (with-current-buffer (process-buffer process)
2148 (if intero-async-network-connected
2149 (when intero-async-network-callback
2150 (when intero-debug (message "Calling callback with %S" (buffer-string)))
2151 (funcall intero-async-network-callback
2152 intero-async-network-state
2153 (buffer-string)))
2154 ;; We didn't successfully connect, so let's fallback to the
2155 ;; process pipe.
2156 (when intero-async-network-callback
2157 (when intero-debug (message "Failed to connect, falling back ... "))
2158 (setq intero-async-network-callback nil)
2159 (intero-async-call
2160 intero-async-network-worker
2161 intero-async-network-cmd
2162 intero-async-network-state
2163 intero-async-network-callback))))
2164 (delete-process process)
2165 (kill-buffer (process-buffer process)))))
2166
2167(defun intero-async-call (worker cmd &optional state callback)
2168 "Send WORKER the command string CMD.
2169The result, along with the given STATE, is passed to CALLBACK
2170as (CALLBACK STATE REPLY)."
2171 (let ((buffer (intero-buffer worker)))
2172 (if (and buffer (process-live-p (get-buffer-process buffer)))
2173 (progn (with-current-buffer buffer
2174 (setq intero-callbacks
2175 (append intero-callbacks
2176 (list (list state
2177 (or callback #'ignore)
2178 cmd)))))
2179 (when intero-debug
2180 (message "[Intero] -> %s" cmd))
2181 (comint-simple-send (intero-process worker) cmd))
2182 (error "Intero process is not running: run M-x intero-restart to start it"))))
2183
2184(defun intero-buffer (worker)
2185 "Get the WORKER buffer for the current directory."
2186 (let ((buffer (intero-get-buffer-create worker))
2187 (targets (buffer-local-value 'intero-targets (current-buffer))))
2188 (if (get-buffer-process buffer)
2189 buffer
2190 (intero-get-worker-create worker targets (current-buffer)
2191 (buffer-local-value
2192 'intero-stack-yaml (current-buffer))))))
2193
2194(defun intero-process (worker)
2195 "Get the WORKER process for the current directory."
2196 (get-buffer-process (intero-buffer worker)))
2197
2198(defun intero-get-worker-create (worker &optional targets source-buffer stack-yaml)
2199 "Start the given WORKER.
2200If provided, use the specified TARGETS, SOURCE-BUFFER and STACK-YAML."
2201 (let* ((buffer (intero-get-buffer-create worker)))
2202 (if (get-buffer-process buffer)
2203 buffer
2204 (let ((install-status (intero-installed-p)))
2205 (if (eq install-status 'installed)
2206 (intero-start-process-in-buffer buffer targets source-buffer stack-yaml)
2207 (intero-auto-install buffer install-status targets source-buffer stack-yaml))))))
2208
2209(defun intero-auto-install (buffer install-status &optional targets source-buffer stack-yaml)
2210 "Automatically install Intero appropriately for BUFFER.
2211INSTALL-STATUS indicates the current installation status.
2212If supplied, use the given TARGETS, SOURCE-BUFFER and STACK-YAML."
2213 (if (buffer-local-value 'intero-give-up buffer)
2214 buffer
2215 (let ((source-buffer (or source-buffer (current-buffer))))
2216 (switch-to-buffer buffer)
2217 (erase-buffer)
2218 (insert (cl-case install-status
2219 (not-installed "Intero is not installed in the Stack environment.")
2220 (wrong-version "The wrong version of Intero is installed for this Emacs package.")))
2221 (if (intero-version>= (intero-stack-version) '(1 6 1))
2222 (intero-copy-compiler-tool-auto-install source-buffer targets buffer)
2223 (intero-old-auto-install source-buffer targets buffer stack-yaml)))))
2224
2225(defun intero-copy-compiler-tool-auto-install (source-buffer targets buffer)
2226 "Automatically install Intero appropriately for BUFFER.
2227Use the given TARGETS, SOURCE-BUFFER and STACK-YAML."
2228 (let ((ghc-version (intero-ghc-version-raw)))
2229 (insert
2230 (format "
2231
2232Installing intero-%s for GHC %s ...
2233
2234" intero-package-version ghc-version))
2235 (redisplay)
2236 (cl-case
2237 (let ((default-directory (make-temp-file "intero" t)))
2238 (intero-call-stack
2239 nil (current-buffer) t nil "build"
2240 "--copy-compiler-tool"
2241 (concat "intero-" intero-package-version)
2242 "--flag" "haskeline:-terminfo"
2243 "--resolver" (concat "ghc-" ghc-version)
2244 "ghc-paths-0.1.0.9" "mtl-2.2.2" "network-2.7.0.0" "random-1.1" "syb-0.7"))
2245 (0
2246 (message "Installed successfully! Starting Intero in a moment ...")
2247 (bury-buffer buffer)
2248 (switch-to-buffer source-buffer)
2249 (intero-start-process-in-buffer buffer targets source-buffer))
2250 (1
2251 (with-current-buffer buffer (setq-local intero-give-up t))
2252 (insert (propertize "Could not install Intero!
2253
2254We don't know why it failed. Please read the above output and try
2255installing manually. If that doesn't work, report this as a
2256problem.
2257
2258Guess: You might need the \"tinfo\" package, e.g. libtinfo-dev.
2259
2260WHAT TO DO NEXT
2261
2262If you don't want to Intero to try installing itself again for
2263this project, just keep this buffer around in your Emacs.
2264
2265If you'd like to try again next time you try use an Intero
2266feature, kill this buffer.
2267"
2268 'face 'compilation-error))
2269 nil))))
2270
2271(defun intero-old-auto-install (source-buffer targets buffer stack-yaml)
2272 "Automatically install Intero appropriately for BUFFER.
2273Use the given TARGETS, SOURCE-BUFFER and STACK-YAML."
2274 (insert
2275 "
2276
2277Installing intero-%s automatically ...
2278
2279" intero-package-version)
2280 (redisplay)
2281 (cl-case (intero-call-stack
2282 nil (current-buffer) t stack-yaml
2283 "build"
2284 (with-current-buffer buffer
2285 (let* ((cabal-file (intero-cabal-find-file))
2286 (package-name (intero-package-name cabal-file)))
2287 ;; For local development. Most users'll
2288 ;; never hit this behaviour.
2289 (if (string= package-name "intero")
2290 "intero"
2291 (concat "intero-" intero-package-version))))
2292 "ghc-paths" "syb"
2293 "--flag" "haskeline:-terminfo")
2294 (0
2295 (message "Installed successfully! Starting Intero in a moment ...")
2296 (bury-buffer buffer)
2297 (switch-to-buffer source-buffer)
2298 (intero-start-process-in-buffer buffer targets source-buffer))
2299 (1
2300 (with-current-buffer buffer (setq-local intero-give-up t))
2301 (insert (propertize "Could not install Intero!
2302
2303We don't know why it failed. Please read the above output and try
2304installing manually. If that doesn't work, report this as a
2305problem.
2306
2307WHAT TO DO NEXT
2308
2309If you don't want to Intero to try installing itself again for
2310this project, just keep this buffer around in your Emacs.
2311
2312If you'd like to try again next time you try use an Intero
2313feature, kill this buffer.
2314"
2315 'face 'compilation-error))
2316 nil)))
2317
2318(defun intero-start-process-in-buffer (buffer &optional targets source-buffer stack-yaml)
2319 "Start an Intero worker in BUFFER.
2320Uses the specified TARGETS if supplied.
2321Automatically performs initial actions in SOURCE-BUFFER, if specified.
2322Uses the default stack config file, or STACK-YAML file if given."
2323 (if (buffer-local-value 'intero-give-up buffer)
2324 buffer
2325 (let* ((process-info (intero-start-piped-process buffer targets stack-yaml))
2326 (arguments (plist-get process-info :arguments))
2327 (options (plist-get process-info :options))
2328 (process (plist-get process-info :process)))
2329 (set-process-query-on-exit-flag process nil)
2330 (process-send-string process ":set -fobject-code\n")
2331 (process-send-string process ":set -fdefer-type-errors\n")
2332 (process-send-string process ":set -fdiagnostics-color=never\n")
2333 (process-send-string process ":set prompt \"\\4\"\n")
2334 (with-current-buffer buffer
2335 (erase-buffer)
2336 (when stack-yaml
2337 (setq intero-stack-yaml stack-yaml))
2338 (setq intero-targets targets)
2339 (setq intero-start-time (current-time))
2340 (setq intero-source-buffer source-buffer)
2341 (setq intero-arguments arguments)
2342 (setq intero-starting t)
2343 (setq intero-callbacks
2344 (list (list (cons source-buffer
2345 buffer)
2346 (lambda (buffers msg)
2347 (let ((source-buffer (car buffers))
2348 (process-buffer (cdr buffers)))
2349 (with-current-buffer process-buffer
2350 (when (string-match "^Intero-Service-Port: \\([0-9]+\\)\n" msg)
2351 (setq intero-service-port (string-to-number (match-string 1 msg))))
2352 (setq-local intero-starting nil))
2353 (when source-buffer
2354 (with-current-buffer source-buffer
2355 (when flycheck-mode
2356 (run-with-timer 0 nil
2357 'intero-call-in-buffer
2358 (current-buffer)
2359 'intero-flycheck-buffer)))))
2360 (message "Booted up intero!"))))))
2361 (set-process-filter
2362 process
2363 (lambda (process string)
2364 (when intero-debug
2365 (message "[Intero] <- %s" string))
2366 (when (buffer-live-p (process-buffer process))
2367 (with-current-buffer (process-buffer process)
2368 (goto-char (point-max))
2369 (insert string)
2370 (when (and intero-try-with-build
2371 intero-starting)
2372 (let ((last-line (buffer-substring-no-properties
2373 (line-beginning-position)
2374 (line-end-position))))
2375 (if (string-match-p "^Progress" last-line)
2376 (message "Booting up intero (building dependencies: %s)"
2377 (downcase
2378 (or (car (split-string (replace-regexp-in-string
2379 "\u0008+" "\n"
2380 last-line)
2381 "\n" t))
2382 "...")))
2383 (message "Booting up intero ..."))))
2384 (intero-read-buffer)))))
2385 (set-process-sentinel process 'intero-sentinel)
2386 buffer)))
2387
2388(defun intero-start-piped-process (buffer targets stack-yaml)
2389 "Start a piped process that we control in BUFFER.
2390Uses the specified TARGETS if supplied.
2391Uses the default stack config file, or STACK-YAML file if given."
2392 (let* ((options
2393 (intero-make-options-list
2394 (intero-executable-path stack-yaml)
2395 (or targets
2396 (let ((package-name (buffer-local-value 'intero-package-name buffer)))
2397 (unless (equal "" package-name)
2398 (list package-name))))
2399 (not (buffer-local-value 'intero-try-with-build buffer))
2400 t ;; pass --no-load to stack
2401 t ;; pass -ignore-dot-ghci to intero
2402 stack-yaml ;; let stack choose a default when nil
2403 ))
2404 (arguments (cons "ghci" options))
2405 (process
2406 (with-current-buffer buffer
2407 (when intero-debug
2408 (message "Intero arguments: %s" (combine-and-quote-strings arguments)))
2409 (message "Booting up intero ...")
2410 (apply #'start-file-process intero-stack-executable buffer intero-stack-executable
2411 arguments))))
2412 (list :arguments arguments
2413 :options options
2414 :process process)))
2415
2416(defun intero-flycheck-buffer ()
2417 "Run flycheck in the buffer.
2418Restarts flycheck in case there was a problem and flycheck is stuck."
2419 (flycheck-mode -1)
2420 (flycheck-mode)
2421 (flycheck-buffer))
2422
2423(defun intero-make-options-list (with-ghc targets no-build no-load ignore-dot-ghci stack-yaml)
2424 "Make the stack ghci options list.
2425TARGETS are the build targets. When non-nil, NO-BUILD and
2426NO-LOAD enable the correspondingly-named stack options. When
2427IGNORE-DOT-GHCI is non-nil, it enables the corresponding GHCI
2428option. STACK-YAML is the stack config file to use (or stack's
2429default when nil)."
2430 (append (when stack-yaml
2431 (list "--stack-yaml" stack-yaml))
2432 (list "--with-ghc"
2433 with-ghc
2434 "--docker-run-args=--interactive=true --tty=false"
2435 )
2436 (when no-build
2437 (list "--no-build"))
2438 (when no-load
2439 (list "--no-load"))
2440 (when ignore-dot-ghci
2441 (list "--ghci-options" "-ignore-dot-ghci"))
2442 (cl-mapcan (lambda (x) (list "--ghci-options" x)) intero-extra-ghc-options)
2443 targets))
2444
2445(defun intero-sentinel (process change)
2446 "Handle when PROCESS reports a CHANGE.
2447This is a standard process sentinel function."
2448 (when (buffer-live-p (process-buffer process))
2449 (unless (process-live-p process)
2450 (let ((buffer (process-buffer process)))
2451 (if (with-current-buffer buffer intero-deleting)
2452 (message "Intero process deleted.")
2453 (if (and (intero-unsatisfied-package-p buffer)
2454 (not (buffer-local-value 'intero-try-with-build buffer)))
2455 (progn (with-current-buffer buffer (setq-local intero-try-with-build t))
2456 (intero-start-process-in-buffer
2457 buffer
2458 (buffer-local-value 'intero-targets buffer)
2459 (buffer-local-value 'intero-source-buffer buffer)))
2460 (progn (with-current-buffer buffer (setq-local intero-give-up t))
2461 (intero-show-process-problem process change))))))))
2462
2463(defun intero-unsatisfied-package-p (buffer)
2464 "Return non-nil if BUFFER contain GHCi's unsatisfied package complaint."
2465 (with-current-buffer buffer
2466 (save-excursion
2467 (goto-char (point-min))
2468 (search-forward-regexp "cannot satisfy -package" nil t 1))))
2469
2470(defun intero-executable-path (stack-yaml)
2471 "The path for the intero executable."
2472 (intero-with-temp-buffer
2473 (cl-case (save-excursion
2474 (intero-call-stack
2475 nil (current-buffer) t intero-stack-yaml "path" "--compiler-tools-bin"))
2476 (0 (replace-regexp-in-string "[\r\n]+$" "/intero" (buffer-string)))
2477 (1 "intero"))))
2478
2479(defun intero-installed-p ()
2480 "Return non-nil if intero (of the right version) is installed in the stack environment."
2481 (redisplay)
2482 (intero-with-temp-buffer
2483 (if (= 0 (intero-call-stack
2484 nil t nil intero-stack-yaml
2485 "exec"
2486 "--verbosity" "silent"
2487 "--"
2488 (intero-executable-path intero-stack-yaml)
2489 "--version"))
2490 (progn
2491 (goto-char (point-min))
2492 ;; This skipping comes due to https://github.com/commercialhaskell/intero/pull/216/files
2493 (when (looking-at "Intero ")
2494 (goto-char (match-end 0)))
2495 ;;
2496 (if (string= (buffer-substring (point) (line-end-position))
2497 intero-package-version)
2498 'installed
2499 'wrong-version))
2500 'not-installed)))
2501
2502(defun intero-show-process-problem (process change)
2503 "Report to the user that PROCESS reported CHANGE, causing it to end."
2504 (message "Problem with Intero!")
2505 (switch-to-buffer (process-buffer process))
2506 (goto-char (point-max))
2507 (insert "\n---\n\n")
2508 (insert
2509 (propertize
2510 (concat
2511 "This is the buffer where Emacs talks to intero. It's normally hidden,
2512but a problem occcured.
2513
2514TROUBLESHOOTING
2515
2516It may be obvious if there is some text above this message
2517indicating a problem.
2518
2519If you do not wish to use Intero for some projects, see
2520https://github.com/commercialhaskell/intero#whitelistingblacklisting-projects
2521
2522The process ended. Here is the reason that Emacs gives us:
2523
2524"
2525 " " change
2526 "\n"
2527 "For troubleshooting purposes, here are the arguments used to launch intero:
2528
2529"
2530 (format " %s %s"
2531 intero-stack-executable
2532 (combine-and-quote-strings intero-arguments))
2533
2534 "
2535
2536It's worth checking that the correct stack executable is being
2537found on your path, or has been set via
2538`intero-stack-executable'. The executable being used now is:
2539
2540 "
2541 (executable-find intero-stack-executable)
2542 "
2543
2544WHAT TO DO NEXT
2545
2546If you fixed the problem, just kill this buffer, Intero will make
2547a fresh one and attempt to start the process automatically as
2548soon as you start editing code again.
2549
2550If you are unable to fix the problem, just leave this buffer
2551around in Emacs and Intero will not attempt to start the process
2552anymore.
2553
2554You can always run M-x intero-restart to make it try again.
2555
2556")
2557 'face 'compilation-error)))
2558
2559(defun intero-read-buffer ()
2560 "In the process buffer, we read what's in it."
2561 (let ((repeat t))
2562 (while repeat
2563 (setq repeat nil)
2564 (goto-char (point-min))
2565 (when (search-forward "\4" (point-max) t 1)
2566 (let* ((next-callback (pop intero-callbacks))
2567 (state (nth 0 next-callback))
2568 (func (nth 1 next-callback)))
2569 (let ((string (intero-strip-carriage-returns (buffer-substring (point-min) (1- (point))))))
2570 (if next-callback
2571 (progn (intero-with-temp-buffer
2572 (funcall func state string))
2573 (setq repeat t))
2574 (when intero-debug
2575 (intero--warn "Received output but no callback in `intero-callbacks': %S"
2576 string)))))
2577 (delete-region (point-min) (point))))))
2578
2579(defun intero-strip-carriage-returns (string)
2580 "Strip the \\r from Windows \\r\\n line endings in STRING."
2581 (replace-regexp-in-string "\r" "" string))
2582
2583(defun intero-get-buffer-create (worker)
2584 "Get or create the stack buffer for WORKER.
2585Uses the directory of the current buffer for context."
2586 (let* ((root (intero-extend-path-by-buffer-host (intero-project-root)))
2587 (cabal-file (intero-cabal-find-file))
2588 (package-name (if cabal-file
2589 (intero-package-name cabal-file)
2590 ""))
2591 (initial-buffer (current-buffer))
2592 (buffer-name (intero-buffer-name worker))
2593 (default-directory (if cabal-file
2594 (file-name-directory cabal-file)
2595 root)))
2596 (with-current-buffer
2597 (get-buffer-create buffer-name)
2598 (intero-inherit-local-variables initial-buffer)
2599 (setq intero-package-name package-name)
2600 (cd default-directory)
2601 (current-buffer))))
2602
2603(defun intero-gave-up (worker)
2604 "Return non-nil if starting WORKER or installing intero failed."
2605 (and (intero-buffer-p worker)
2606 (let ((buffer (get-buffer (intero-buffer-name worker))))
2607 (buffer-local-value 'intero-give-up buffer))))
2608
2609(defun intero-buffer-p (worker)
2610 "Return non-nil if a buffer exists for WORKER."
2611 (get-buffer (intero-buffer-name worker)))
2612
2613(defun intero-buffer-name (worker)
2614 "For a given WORKER, create a buffer name."
2615 (let* ((root (intero-project-root))
2616 (package-name (intero-package-name)))
2617 (concat " intero:"
2618 (format "%s" worker)
2619 ":"
2620 package-name
2621 " "
2622 root)))
2623
2624(defun intero-project-root ()
2625 "Get the current stack config directory.
2626This is the directory where the file specified in
2627`intero-stack-yaml' is located, or if nil then the directory
2628where stack.yaml is placed for this project, or the global one if
2629no such project-specific config exists."
2630 (if intero-project-root
2631 intero-project-root
2632 (let ((stack-yaml intero-stack-yaml))
2633 (setq intero-project-root
2634 (intero-with-temp-buffer
2635 (cl-case (save-excursion
2636 (intero-call-stack nil (current-buffer) nil stack-yaml
2637 "path"
2638 "--project-root"
2639 "--verbosity" "silent"))
2640 (0 (buffer-substring (line-beginning-position) (line-end-position)))
2641 (t (intero--warn "Couldn't get the Stack project root.
2642
2643This can be caused by a syntax error in your stack.yaml file. Check that out.
2644
2645If you do not wish to use Intero for some projects, see
2646https://github.com/commercialhaskell/intero#whitelistingblacklisting-projects
2647
2648Otherwise, please report this as a bug!
2649
2650For debugging purposes, try running the following in your terminal:
2651
2652%s path --project-root" intero-stack-executable)
2653 nil)))))))
2654
2655(defun intero-ghc-version ()
2656 "Get the GHC version used by the project, calls only once per backend."
2657 (with-current-buffer (intero-buffer 'backend)
2658 (or intero-ghc-version
2659 (setq intero-ghc-version
2660 (intero-ghc-version-raw)))))
2661
2662(defun intero-ghc-version-raw ()
2663 "Get the GHC version used by the project."
2664 (intero-with-temp-buffer
2665 (cl-case (save-excursion
2666 (intero-call-stack
2667 nil (current-buffer) t intero-stack-yaml
2668 "ghc" "--" "--numeric-version"))
2669 (0
2670 (buffer-substring (line-beginning-position) (line-end-position)))
2671 (1 nil))))
2672
2673(defun intero-version>= (new0 old0)
2674 "Is the version NEW >= OLD?"
2675 (or (and (null new0) (null old0))
2676 (let ((new (or new0 (list 0)))
2677 (old (or old0 (list 0))))
2678 (or (> (car new)
2679 (car old))
2680 (and (= (car new)
2681 (car old))
2682 (intero-version>= (cdr new)
2683 (cdr old)))))))
2684
2685(defun intero-stack-version ()
2686 "Get the version components of stack."
2687 (let* ((str (intero-stack-version-raw))
2688 (parts (mapcar #'string-to-number (split-string str "\\."))))
2689 parts))
2690
2691(defun intero-stack-version-raw ()
2692 "Get the Stack version in PATH."
2693 (intero-with-temp-buffer
2694 (cl-case (save-excursion
2695 (intero-call-stack
2696 nil (current-buffer) t intero-stack-yaml "--numeric-version"))
2697 (0
2698 (buffer-substring (line-beginning-position) (line-end-position)))
2699 (1 nil))))
2700
2701(defun intero-get-targets ()
2702 "Get all available targets."
2703 (with-current-buffer (intero-buffer 'backend)
2704 (intero-with-temp-buffer
2705 (cl-case (intero-call-stack nil (current-buffer) t
2706 intero-stack-yaml
2707 "ide" "targets")
2708 (0
2709 (cl-remove-if-not
2710 (lambda (line)
2711 (string-match-p "^[A-Za-z0-9-:_]+$" line))
2712 (split-string (buffer-string) "[\r\n]" t)))
2713 (1 nil)))))
2714
2715(defun intero-package-name (&optional cabal-file)
2716 "Get the current package name from a nearby .cabal file.
2717If there is none, return an empty string. If specified, use
2718CABAL-FILE rather than trying to locate one."
2719 (or intero-package-name
2720 (setq intero-package-name
2721 (let ((cabal-file (or cabal-file
2722 (intero-cabal-find-file))))
2723 (if cabal-file
2724 (replace-regexp-in-string
2725 ".cabal$" ""
2726 (file-name-nondirectory cabal-file))
2727 "")))))
2728
2729(defun intero-cabal-find-file (&optional dir)
2730 "Search for package description file upwards starting from DIR.
2731If DIR is nil, `default-directory' is used as starting point for
2732directory traversal. Upward traversal is aborted if file owner
2733changes. Uses `intero-cabal-find-pkg-desc' internally."
2734 (let ((use-dir (or dir default-directory)))
2735 (while (and use-dir (not (file-directory-p use-dir)))
2736 (setq use-dir (file-name-directory (directory-file-name use-dir))))
2737 (when use-dir
2738 (catch 'found
2739 (let ((user (nth 2 (file-attributes use-dir)))
2740 ;; Abbreviate, so as to stop when we cross ~/.
2741 (root (abbreviate-file-name use-dir)))
2742 ;; traverse current dir up to root as long as file owner doesn't change
2743 (while (and root (equal user (nth 2 (file-attributes root))))
2744 (let ((cabal-file (intero-cabal-find-pkg-desc root)))
2745 (when cabal-file
2746 (throw 'found cabal-file)))
2747
2748 (let ((proot (file-name-directory (directory-file-name root))))
2749 (if (equal proot root) ;; fix-point reached?
2750 (throw 'found nil)
2751 (setq root proot))))
2752 nil)))))
2753
2754(defun intero-cabal-find-pkg-desc (dir &optional allow-multiple)
2755 "Find a package description file in the directory DIR.
2756Returns nil if none or multiple \".cabal\" files were found. If
2757ALLOW-MULTIPLE is non nil, in case of multiple \".cabal\" files,
2758a list is returned instead of failing with a nil result."
2759 ;; This is basically a port of Cabal's
2760 ;; Distribution.Simple.Utils.findPackageDesc function
2761 ;; http://hackage.haskell.org/packages/archive/Cabal/1.16.0.3/doc/html/Distribution-Simple-Utils.html
2762 ;; but without the exception throwing.
2763 (let* ((cabal-files
2764 (cl-remove-if (lambda (path)
2765 (or (file-directory-p path)
2766 (not (file-exists-p path))))
2767 (directory-files dir t ".\\.cabal\\'" t))))
2768 (cond
2769 ((= (length cabal-files) 1) (car cabal-files)) ;; exactly one candidate found
2770 (allow-multiple cabal-files) ;; pass-thru multiple candidates
2771 (t nil))))
2772
2773;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2774;; Multiselection
2775
2776(defvar intero-multiswitch-keymap
2777 (let ((map (copy-keymap widget-keymap)))
2778 (define-key map (kbd "C-c C-c") 'exit-recursive-edit)
2779 (define-key map (kbd "C-c C-k") 'abort-recursive-edit)
2780 (define-key map (kbd "C-g") 'abort-recursive-edit)
2781 map))
2782
2783(defun intero-multiswitch (title options)
2784 "Displaying TITLE, read multiple flags from a list of OPTIONS.
2785Each option is a plist of (:key :default :title) wherein:
2786
2787 :key should be something comparable with EQUAL
2788 :title should be a string
2789 :default (boolean) specifies the default checkedness"
2790 (let ((available-width (window-total-width)))
2791 (save-window-excursion
2792 (intero-with-temp-buffer
2793 (rename-buffer (generate-new-buffer-name "multiswitch"))
2794 (widget-insert (concat title "\n\n"))
2795 (widget-insert (propertize "Select options with RET, hit " 'face 'font-lock-comment-face))
2796 (widget-create 'push-button :notify
2797 (lambda (&rest ignore)
2798 (exit-recursive-edit))
2799 "C-c C-c")
2800 (widget-insert (propertize " to apply these choices, or hit " 'face 'font-lock-comment-face))
2801 (widget-create 'push-button :notify
2802 (lambda (&rest ignore)
2803 (abort-recursive-edit))
2804 "C-c C-k")
2805 (widget-insert (propertize " to cancel.\n\n" 'face 'font-lock-comment-face))
2806 (let* ((me (current-buffer))
2807 (choices (mapcar (lambda (option)
2808 (append option (list :value (plist-get option :default))))
2809 options)))
2810 (cl-loop for option in choices
2811 do (widget-create
2812 'toggle
2813 :notify (lambda (widget &rest ignore)
2814 (setq choices
2815 (mapcar (lambda (choice)
2816 (if (equal (plist-get choice :key)
2817 (plist-get (cdr widget) :key))
2818 (plist-put choice :value (plist-get (cdr widget) :value))
2819 choice))
2820 choices)))
2821 :on (concat "[x] " (plist-get option :title))
2822 :off (concat "[ ] " (plist-get option :title))
2823 :value (plist-get option :default)
2824 :key (plist-get option :key)))
2825 (let ((lines (line-number-at-pos)))
2826 (select-window (split-window-below))
2827 (switch-to-buffer me)
2828 (goto-char (point-min)))
2829 (use-local-map intero-multiswitch-keymap)
2830 (widget-setup)
2831 (recursive-edit)
2832 (kill-buffer me)
2833 (mapcar (lambda (choice)
2834 (plist-get choice :key))
2835 (cl-remove-if-not (lambda (choice)
2836 (plist-get choice :value))
2837 choices)))))))
2838
2839;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2840;; Hoogle
2841
2842(defun intero-hoogle-blocking-query (query)
2843 "Make a request of QUERY using the local hoogle server.
2844If running, otherwise returns nil.
2845
2846It is the responsibility of the caller to make sure the server is
2847running; the user might not want to start the server
2848automatically."
2849 (let ((buffer (intero-hoogle-get-buffer)))
2850 (when buffer
2851 (let ((url (intero-hoogle-url buffer query)))
2852 (with-current-buffer (url-retrieve-synchronously url t)
2853 (search-forward "\n\n" nil t 1)
2854 (json-read-from-string
2855 (buffer-substring (line-beginning-position)
2856 (line-end-position))))))))
2857
2858(defun intero-hoogle-url (buffer query)
2859 "Via hoogle server BUFFER make the HTTP URL for QUERY."
2860 (format "http://127.0.0.1:%d/?hoogle=%s&mode=json"
2861 (buffer-local-value 'intero-hoogle-port buffer)
2862 (url-encode-url query)))
2863
2864(defun intero-hoogle-get-worker-create ()
2865 "Get or create the hoogle worker."
2866 (let* ((buffer (intero-hoogle-get-buffer-create)))
2867 (if (get-buffer-process buffer)
2868 buffer
2869 (intero-start-hoogle-process-in-buffer buffer))))
2870
2871(defun intero-start-hoogle-process-in-buffer (buffer)
2872 "Start the process in BUFFER, returning BUFFER."
2873 (let* ((port (intero-free-port))
2874 (process (with-current-buffer buffer
2875 (message "Booting up hoogle ...")
2876 (setq intero-hoogle-port port)
2877 (start-process "hoogle"
2878 buffer
2879 intero-stack-executable
2880 "hoogle"
2881 "server"
2882 "--no-setup"
2883 "--"
2884 "--local"
2885 "--port"
2886 (number-to-string port)))))
2887 (set-process-query-on-exit-flag process nil)
2888 (set-process-sentinel process 'intero-hoogle-sentinel)
2889 buffer))
2890
2891(defun intero-free-port ()
2892 "Get the next free port to use."
2893 (let ((proc (make-network-process
2894 :name "port-check"
2895 :family 'ipv4
2896 :host "127.0.0.1"
2897 :service t
2898 :server t)))
2899 (delete-process proc)
2900 (process-contact proc :service)))
2901
2902(defun intero-hoogle-sentinel (process change)
2903 "For the hoogle PROCESS there is a CHANGE to handle."
2904 (message "Hoogle sentinel: %S %S" process change))
2905
2906(defun intero-hoogle-get-buffer-create ()
2907 "Get or create the Hoogle buffer for the current stack project."
2908 (let* ((root (intero-project-root))
2909 (buffer-name (intero-hoogle-buffer-name root))
2910 (buf (get-buffer buffer-name))
2911 (initial-buffer (current-buffer))
2912 (default-directory root))
2913 (if buf
2914 buf
2915 (with-current-buffer (get-buffer-create buffer-name)
2916 (intero-inherit-local-variables initial-buffer)
2917 (cd default-directory)
2918 (current-buffer)))))
2919
2920(defun intero-hoogle-get-buffer ()
2921 "Get the Hoogle buffer for the current stack project."
2922 (let* ((root (intero-project-root))
2923 (buffer-name (intero-hoogle-buffer-name root)))
2924 (get-buffer buffer-name)))
2925
2926(defun intero-hoogle-buffer-name (root)
2927 "For a given worker, create a buffer name using ROOT."
2928 (concat "*Hoogle:" root "*"))
2929
2930(defun intero-hoogle-ready-p ()
2931 "Is hoogle ready to be started?"
2932 (intero-with-temp-buffer
2933 (cl-case (intero-call-stack nil (current-buffer) t intero-stack-yaml
2934 "hoogle" "--no-setup" "--verbosity" "silent")
2935 (0 t))))
2936
2937(defun intero-hoogle-supported-p ()
2938 "Is the stack hoogle command supported?"
2939 (intero-with-temp-buffer
2940 (cl-case (intero-call-stack nil (current-buffer) t
2941 intero-stack-yaml
2942 "hoogle" "--help")
2943 (0 t))))
2944
2945;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2946;; Collecting information from compiler messages
2947
2948(defun intero-collect-compiler-messages (msgs)
2949 "Collect information from compiler MSGS.
2950
2951This may update in-place the MSGS objects to hint that
2952suggestions are available."
2953 (setq intero-suggestions nil)
2954 (let ((extension-regex (concat " " (regexp-opt (intero-extensions) t) "\\>"))
2955 (quoted-symbol-regex "[‘`‛]\\([^ ]+\\)['’]"))
2956 (cl-loop
2957 for msg in msgs
2958 do (let ((text (flycheck-error-message msg))
2959 (note nil))
2960 ;; Messages of this format:
2961 ;;
2962 ;; • Constructor ‘Assert’ does not have the required strict field(s): assertName,
2963 ;; assertDoc, assertExpression,
2964 ;; assertSection
2965 (let ((start 0))
2966 (while (or
2967 (string-match "does not have the required strict field.*?:[\n\t\r ]" text start)
2968 (string-match "Fields of .*? not initialised:[\n\t\r ]" text start))
2969 (let* ((match-end (match-end 0))
2970 (fields
2971 (let ((reached-end nil))
2972 (mapcar
2973 (lambda (field)
2974 (with-temp-buffer
2975 (insert field)
2976 (goto-char (point-min))
2977 (intero-ident-at-point)))
2978 (cl-remove-if
2979 (lambda (field)
2980 (or reached-end
2981 (when (string-match "[\r\n]" field)
2982 (setq reached-end t)
2983 nil)))
2984 (split-string
2985 (substring text match-end)
2986 "[\n\t\r ]*,[\n\t\r ]*" t))))))
2987 (setq note t)
2988 (add-to-list
2989 'intero-suggestions
2990 (list :type 'add-missing-fields
2991 :fields fields
2992 :line (flycheck-error-line msg)
2993 :column (flycheck-error-column msg)))
2994 (setq start (min (length text) (1+ match-end))))))
2995
2996 ;; Messages of this format:
2997 ;;
2998 ;; Can't make a derived instance of ‘Functor X’:
2999 ;; You need DeriveFunctor to derive an instance for this class
3000 ;; Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension
3001 ;; In the newtype declaration for ‘X’
3002 (let ((start 0))
3003 (while (let ((case-fold-search nil))
3004 (string-match extension-regex text start))
3005 (setq note t)
3006 (add-to-list 'intero-suggestions
3007 (list :type 'add-extension
3008 :extension (match-string 1 text)))
3009 (setq start (min (length text) (1+ (match-end 0))))))
3010 ;; Messages of this format:
3011 ;;
3012 ;; Could not find module ‘Language.Haskell.TH’
3013 ;; It is a member of the hidden package ‘template-haskell’.
3014 ;; Use -v to see a list of the files searched for....
3015 (let ((start 0))
3016 (while (string-match "It is a member of the hidden package [‘`‛]\\([^ ]+\\)['’]" text start)
3017 (setq note t)
3018 (add-to-list 'intero-suggestions
3019 (list :type 'add-package
3020 :package (match-string 1 text)))
3021 (setq start (min (length text) (1+ (match-end 0))))))
3022 ;; Messages of this format:
3023 ;; Expected type: String
3024 ;; Actual type: Data.Text.Internal.Builder.Builder
3025 (let ((start 0))
3026 (while (or (string-match
3027 "Expected type: String" text start)
3028 (string-match
3029 "Actual type: String" text start)
3030 (string-match
3031 "Actual type: \\[Char\\]" text start)
3032 (string-match
3033 "Expected type: \\[Char\\]" text start))
3034 (setq note t)
3035 (add-to-list 'intero-suggestions
3036 (list :type 'add-extension
3037 :extension "OverloadedStrings"))
3038 (setq start (min (length text) (1+ (match-end 0))))))
3039 ;; Messages of this format:
3040 ;;
3041 ;; Defaulting the following constraint(s) to type ‘Integer’
3042 ;; (Num a0) arising from the literal ‘1’
3043 ;; In the expression: 2
3044 ;; In an equation for ‘x'’: x' = 2
3045 (let ((start 0))
3046 (while (string-match
3047 " Defaulting the following constraint" text start)
3048 (setq note t)
3049 (add-to-list 'intero-suggestions
3050 (list :type 'add-ghc-option
3051 :option "-fno-warn-type-defaults"))
3052 (setq start (min (length text) (1+ (match-end 0))))))
3053 ;; Messages of this format:
3054 ;;
3055 ;; This binding for ‘x’ shadows the existing binding
3056 (let ((start 0))
3057 (while (string-match
3058 " This binding for ‘\\(.*\\)’ shadows the existing binding" text start)
3059 (setq note t)
3060 (add-to-list 'intero-suggestions
3061 (list :type 'add-ghc-option
3062 :option "-fno-warn-name-shadowing"))
3063 (setq start (min (length text) (1+ (match-end 0))))))
3064 ;; Messages of this format:
3065 ;; Perhaps you want to add ‘foo’ to the import list
3066 ;; in the import of ‘Blah’
3067 ;; (/path/to/thing:19
3068 (when (string-match "Perhaps you want to add [‘`‛]\\([^ ]+\\)['’][\n ]+to[\n ]+the[\n ]+import[\n ]+list[\n ]+in[\n ]+the[\n ]+import[\n ]+of[\n ]+[‘`‛]\\([^ ]+\\)['’][\n ]+(\\([^ ]+\\):(?\\([0-9]+\\)[:,]"
3069 text)
3070 (let ((ident (match-string 1 text))
3071 (module (match-string 2 text))
3072 (file (match-string 3 text))
3073 (line (string-to-number (match-string 4 text))))
3074 (setq note t)
3075 (add-to-list 'intero-suggestions
3076 (list :type 'add-to-import
3077 :module module
3078 :ident ident
3079 :line line))))
3080 ;; Messages of this format:
3081 ;;
3082 ;; The import of ‘Control.Monad’ is redundant
3083 ;; except perhaps to import instances from ‘Control.Monad’
3084 ;; To import instances alone, use: import Control.Monad()... (intero)
3085 (when (string-match
3086 " The \\(qualified \\)?import of[ ][‘`‛]\\([^ ]+\\)['’] is redundant"
3087 text)
3088 (setq note t)
3089 (add-to-list 'intero-suggestions
3090 (list :type 'remove-import
3091 :module (match-string 2 text)
3092 :line (flycheck-error-line msg))))
3093 ;; Messages of this format:
3094 ;;
3095 ;; Not in scope: ‘putStrn’
3096 ;; Perhaps you meant one of these:
3097 ;; ‘putStr’ (imported from Prelude),
3098 ;; ‘putStrLn’ (imported from Prelude)
3099 ;;
3100 ;; Or this format:
3101 ;;
3102 ;; error:
3103 ;; • Variable not in scope: lopSetup :: [Statement Exp']
3104 ;; • Perhaps you meant ‘loopSetup’ (line 437)
3105 (when (string-match
3106 "[Nn]ot in scope: \\(data constructor \\|type constructor or class \\)?[‘`‛]?\\([^'’ ]+\\).*\n.*Perhaps you meant"
3107 text)
3108 (let ((typo (match-string 2 text))
3109 (start (min (length text) (1+ (match-end 0)))))
3110 (while (string-match quoted-symbol-regex text start)
3111 (setq note t)
3112 (add-to-list 'intero-suggestions
3113 (list :type 'fix-typo
3114 :typo typo
3115 :replacement (match-string 1 text)
3116 :column (flycheck-error-column msg)
3117 :line (flycheck-error-line msg)))
3118 (setq start (min (length text) (1+ (match-end 0)))))))
3119 ;; Messages of this format:
3120 ;;
3121 ;; Top-level binding with no type signature: main :: IO ()
3122 (when (string-match
3123 "Top-level binding with no type signature:"
3124 text)
3125 (let ((start (min (length text) (match-end 0))))
3126 (setq note t)
3127 (add-to-list 'intero-suggestions
3128 (list :type 'add-signature
3129 :signature (mapconcat #'identity (split-string (substring text start)) " ")
3130 :line (flycheck-error-line msg)))))
3131 ;; Messages of this format:
3132 (when (string-match "The import of [‘`‛]\\(.+?\\)[’`'][\n ]+from[\n ]+module[\n ]+[‘`‛]\\(.+?\\)[’`'][\n ]+is[\n ]+redundant" text)
3133 (let ((module (match-string 2 text))
3134 (idents (split-string (match-string 1 text) "," t "[ \n]+")))
3135 (setq note t)
3136 (add-to-list 'intero-suggestions
3137 (list :type 'redundant-import-item
3138 :idents idents
3139 :line (flycheck-error-line msg)
3140 :module module))))
3141 ;; Messages of this format:
3142 ;;
3143 ;; Redundant constraints: (Arith var, Bitwise var)
3144 ;; Or
3145 ;; Redundant constraint: Arith var
3146 ;; Or
3147 ;; Redundant constraints: (Arith var,
3148 ;; Bitwise var,
3149 ;; Functor var,
3150 ;; Applicative var,
3151 ;; Monad var)
3152 (when (string-match "Redundant constraints?: " text)
3153 (let* ((redundant-start (match-end 0))
3154 (parts (intero-with-temp-buffer
3155 (insert (substring text redundant-start))
3156 (goto-char (point-min))
3157 ;; A lone unparenthesized constraint might
3158 ;; be multiple sexps.
3159 (while (not (eq (point) (point-at-eol)))
3160 (forward-sexp))
3161 (let ((redundant-end (point)))
3162 (search-forward-regexp ".*\n.*In the ")
3163 (cons (buffer-substring (point-min) redundant-end)
3164 (buffer-substring (match-end 0) (point-max)))))))
3165 (setq note t)
3166 (add-to-list
3167 'intero-suggestions
3168 (let ((rest (cdr parts))
3169 (redundant (let ((raw (car parts)))
3170 (if (eq (string-to-char raw) ?\()
3171 (substring raw 1 (1- (length raw)))
3172 raw))))
3173 (list :type 'redundant-constraint
3174 :redundancies (mapcar #'string-trim
3175 (intero-parse-comma-list redundant))
3176 :signature (mapconcat #'identity (split-string rest) " ")
3177 :line (flycheck-error-line msg))))))
3178 ;; Add a note if we found a suggestion to make
3179 (when note
3180 (setf (flycheck-error-message msg)
3181 (concat text "\n\n"
3182 (propertize
3183 (substitute-command-keys
3184 "(Hit `\\[intero-apply-suggestions]' in the Haskell buffer to apply suggestions)")
3185 'face 'font-lock-warning-face)))))))
3186 (setq intero-lighter
3187 (if (null intero-suggestions)
3188 " Intero"
3189 (format " Intero:%d" (length intero-suggestions)))))
3190
3191(defun intero-extensions ()
3192 "Get extensions for the current project's GHC."
3193 (with-current-buffer (intero-buffer 'backend)
3194 (or intero-extensions
3195 (setq intero-extensions
3196 (cl-remove-if-not
3197 (lambda (str) (let ((case-fold-search nil))
3198 (string-match "^[A-Z][A-Za-z0-9]+$" str)))
3199 (split-string
3200 (shell-command-to-string
3201 (concat intero-stack-executable
3202 (if intero-stack-yaml
3203 (concat "--stack-yaml " intero-stack-yaml)
3204 "")
3205 " exec --verbosity silent -- ghc --supported-extensions"))))))))
3206
3207;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3208;; Auto actions
3209
3210(defun intero-parse-comma-list (text)
3211 "Parse a list of comma-separated expressions in TEXT."
3212 (cl-loop for tok in (split-string text "[[:space:]\n]*,[[:space:]\n]*")
3213 with acc = nil
3214 append (let* ((clist (string-to-list tok))
3215 (num-open (-count (lambda (c) (or (eq c ?\() (eq c ?\[)))
3216 clist))
3217 (num-close (-count (lambda (c) (or (eq c ?\)) (eq c ?\])))
3218 clist)))
3219 (cond
3220 ((> num-open num-close) (progn (add-to-list 'acc tok) nil))
3221 ((> num-close num-open) (let ((tmp (reverse (cons tok acc))))
3222 (setq acc nil)
3223 (list (string-join tmp ", "))))
3224 (t (list tok))))))
3225
3226(defun intero-apply-suggestions ()
3227 "Prompt and apply the suggestions."
3228 (interactive)
3229 (if (null intero-suggestions)
3230 (message "No suggestions to apply")
3231 (let ((to-apply
3232 (intero-multiswitch
3233 (format "There are %d suggestions to apply:" (length intero-suggestions))
3234 (cl-remove-if-not
3235 #'identity
3236 (mapcar
3237 (lambda (suggestion)
3238 (cl-case (plist-get suggestion :type)
3239 (add-to-import
3240 (list :key suggestion
3241 :title (format "Add ‘%s’ to import of ‘%s’"
3242 (plist-get suggestion :ident)
3243 (plist-get suggestion :module))
3244 :default t))
3245 (add-missing-fields
3246 (list :key suggestion
3247 :default t
3248 :title
3249 (format "Add missing fields to record: %s"
3250 (mapconcat (lambda (ident)
3251 (concat "‘" ident "’"))
3252 (plist-get suggestion :fields)
3253 ", "))))
3254 (redundant-import-item
3255 (list :key suggestion
3256 :title
3257 (format "Remove redundant imports %s from import of ‘%s’"
3258 (mapconcat (lambda (ident)
3259 (concat "‘" ident "’"))
3260 (plist-get suggestion :idents) ", ")
3261 (plist-get suggestion :module))
3262 :default t))
3263 (add-extension
3264 (list :key suggestion
3265 :title (concat "Add {-# LANGUAGE "
3266 (plist-get suggestion :extension)
3267 " #-}")
3268 :default (not (string= "OverloadedStrings" (plist-get suggestion :extension)))))
3269 (add-ghc-option
3270 (list :key suggestion
3271 :title (concat "Add {-# OPTIONS_GHC "
3272 (plist-get suggestion :option)
3273 " #-}")
3274 :default (not
3275 (string=
3276 (plist-get suggestion :option)
3277 "-fno-warn-name-shadowing"))))
3278 (add-package
3279 (list :key suggestion
3280 :title (concat "Enable package: " (plist-get suggestion :package))
3281 :default t))
3282 (remove-import
3283 (list :key suggestion
3284 :title (concat "Remove: import "
3285 (plist-get suggestion :module))
3286 :default t))
3287 (fix-typo
3288 (list :key suggestion
3289 :title (concat "Replace ‘"
3290 (plist-get suggestion :typo)
3291 "’ with ‘"
3292 (plist-get suggestion :replacement)
3293 "’")
3294 :default (null (cdr intero-suggestions))))
3295 (add-signature
3296 (list :key suggestion
3297 :title (concat "Add signature: "
3298 (plist-get suggestion :signature))
3299 :default t))
3300 (redundant-constraint
3301 (list :key suggestion
3302 :title (concat
3303 "Remove redundant constraints: "
3304 (string-join (plist-get suggestion :redundancies)
3305 ", ")
3306 "\n from the "
3307 (plist-get suggestion :signature))
3308 :default nil))))
3309 intero-suggestions)))))
3310 (if (null to-apply)
3311 (message "No changes selected to apply.")
3312 (let ((sorted (sort to-apply
3313 (lambda (lt gt)
3314 (let ((lt-line (or (plist-get lt :line) 0))
3315 (lt-column (or (plist-get lt :column) 0))
3316 (gt-line (or (plist-get gt :line) 0))
3317 (gt-column (or (plist-get gt :column) 0)))
3318 (or (> lt-line gt-line)
3319 (and (= lt-line gt-line)
3320 (> lt-column gt-column))))))))
3321 ;; # Changes unrelated to the buffer
3322 (cl-loop
3323 for suggestion in sorted
3324 do (cl-case (plist-get suggestion :type)
3325 (add-package
3326 (intero-add-package (plist-get suggestion :package)))))
3327 ;; # Changes that do not increase/decrease line numbers
3328 ;;
3329 ;; Update in-place suggestions
3330 (cl-loop
3331 for suggestion in sorted
3332 do (cl-case (plist-get suggestion :type)
3333 (add-to-import
3334 (save-excursion
3335 (goto-char (point-min))
3336 (forward-line (1- (plist-get suggestion :line)))
3337 (when (and (search-forward (plist-get suggestion :module) nil t 1)
3338 (search-forward "(" nil t 1))
3339 (insert (if (string-match-p "^[_a-zA-Z]" (plist-get suggestion :ident))
3340 (plist-get suggestion :ident)
3341 (concat "(" (plist-get suggestion :ident) ")")))
3342 (unless (looking-at-p "[:space:]*)")
3343 (insert ", ")))))
3344 (redundant-import-item
3345 (save-excursion
3346 (goto-char (point-min))
3347 (forward-line (1- (plist-get suggestion :line)))
3348 (let* ((case-fold-search nil)
3349 (start (search-forward "(" nil t 1))
3350 (end (or (save-excursion
3351 (when (search-forward-regexp "\n[^ \t]" nil t 1)
3352 (1- (point))))
3353 (line-end-position)))
3354 (regex
3355 (concat
3356 "\\("
3357 (mapconcat
3358 (lambda (ident)
3359 (if (string-match-p "^[_a-zA-Z]" ident)
3360 (concat "\\<" (regexp-quote ident) "\\> ?" "\\("(regexp-quote "(..)") "\\)?")
3361 (concat "(" (regexp-quote ident) ")")))
3362 (plist-get suggestion :idents)
3363 "\\|")
3364 "\\)"))
3365 (string (buffer-substring start end)))
3366 (delete-region start end)
3367 (insert
3368 (replace-regexp-in-string
3369 ",[\n ]*)" ")"
3370 (replace-regexp-in-string
3371 "^[\n ,]*" ""
3372 (replace-regexp-in-string
3373 "[\n ,]*,[\n ,]*" ", "
3374 (replace-regexp-in-string
3375 ",[\n ]*)" ")"
3376 (replace-regexp-in-string
3377 regex ""
3378 string)))))
3379 (make-string (1- (length (split-string string "\n" t))) 10)))))
3380 (fix-typo
3381 (save-excursion
3382 (goto-char (point-min))
3383 (forward-line (1- (plist-get suggestion :line)))
3384 (move-to-column (- (plist-get suggestion :column) 1))
3385 (delete-char (length (plist-get suggestion :typo)))
3386 (insert (plist-get suggestion :replacement))))
3387 (add-missing-fields
3388 (save-excursion
3389 (goto-char (point-min))
3390 (forward-line (1- (plist-get suggestion :line)))
3391 (move-to-column (- (plist-get suggestion :column) 1))
3392 (search-forward "{")
3393 (unless (looking-at "}")
3394 (save-excursion (insert ", ")))
3395 (insert (mapconcat (lambda (field) (concat field " = _"))
3396 (plist-get suggestion :fields)
3397 ", "))))))
3398 ;; # Changes that do increase/decrease line numbers
3399 ;;
3400 ;; Remove redundant constraints
3401 (cl-loop
3402 for suggestion in sorted
3403 do (cl-case (plist-get suggestion :type)
3404 (redundant-constraint
3405 (save-excursion
3406 (goto-char (point-min))
3407 (forward-line (1- (plist-get suggestion :line)))
3408 (search-forward-regexp "[[:alnum:][:space:]\n]*=>")
3409 (backward-sexp 2)
3410 (let ((start (1+ (point))))
3411 (forward-sexp)
3412 (let* ((end (1- (point)))
3413 (constraints (intero-parse-comma-list
3414 (buffer-substring start end)))
3415 (nonredundant
3416 (cl-loop for r in (plist-get suggestion :redundancies)
3417 with nonredundant = constraints
3418 do (setq nonredundant (delete r nonredundant))
3419 finally return nonredundant)))
3420 (goto-char start)
3421 (delete-char (- end start))
3422 (insert (string-join nonredundant ", "))))))))
3423
3424 ;; Add a type signature to a top-level binding.
3425 (cl-loop
3426 for suggestion in sorted
3427 do (cl-case (plist-get suggestion :type)
3428 (add-signature
3429 (save-excursion
3430 (goto-char (point-min))
3431 (forward-line (1- (plist-get suggestion :line)))
3432 (insert (plist-get suggestion :signature))
3433 (insert "\n")))))
3434
3435 ;; Remove import lines from the file. May remove more than one
3436 ;; line per import.
3437 (cl-loop
3438 for suggestion in sorted
3439 do (cl-case (plist-get suggestion :type)
3440 (remove-import
3441 (save-excursion
3442 (goto-char (point-min))
3443 (forward-line (1- (plist-get suggestion :line)))
3444 (delete-region (line-beginning-position)
3445 (or (when (search-forward-regexp "\n[^ \t]" nil t 1)
3446 (1- (point)))
3447 (line-end-position)))))))
3448 ;; Add extensions to the top of the file
3449 (cl-loop
3450 for suggestion in sorted
3451 do (cl-case (plist-get suggestion :type)
3452 (add-extension
3453 (save-excursion
3454 (goto-char (point-min))
3455 (intero-skip-shebangs)
3456 (insert "{-# LANGUAGE "
3457 (plist-get suggestion :extension)
3458 " #-}\n")))
3459 (add-ghc-option
3460 (save-excursion
3461 (goto-char (point-min))
3462 (intero-skip-shebangs)
3463 (insert "{-# OPTIONS_GHC "
3464 (plist-get suggestion :option)
3465 " #-}\n"))))))))))
3466
3467(defun intero-skip-shebangs ()
3468 "Skip #! and -- shebangs used in Haskell scripts."
3469 (when (looking-at-p "#!") (forward-line 1))
3470 (when (looking-at-p "-- stack ") (forward-line 1)))
3471
3472(defun intero--warn (message &rest args)
3473 "Display a warning message made from (format MESSAGE ARGS...).
3474Equivalent to 'warn', but label the warning as coming from intero."
3475 (display-warning 'intero (apply 'format message args) :warning))
3476
3477;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3478;; Intero help buffer
3479
3480(defun intero-help-buffer ()
3481 "Get the help buffer."
3482 (with-current-buffer (get-buffer-create "*Intero-Help*")
3483 (unless (eq major-mode 'intero-help-mode) (intero-help-mode))
3484 (current-buffer)))
3485
3486(defvar-local intero-help-entries nil
3487 "History for help entries.")
3488
3489(defun intero-help-pagination ()
3490 "Insert pagination for the current help buffer."
3491 (let ((buffer-read-only nil))
3492 (when (> (length intero-help-entries) 1)
3493 (insert-text-button
3494 "[back]"
3495 'buffer (current-buffer)
3496 'action (lambda (&rest ignore)
3497 (let ((first (pop intero-help-entries)))
3498 (setcdr (last intero-help-entries) (cons first nil))
3499 (intero-help-refresh)))
3500 'keymap (let ((map (make-sparse-keymap)))
3501 (define-key map [mouse-1] 'push-button)
3502 map))
3503 (insert " ")
3504 (insert-text-button
3505 "[forward]"
3506 'buffer (current-buffer)
3507 'keymap (let ((map (make-sparse-keymap)))
3508 (define-key map [mouse-1] 'push-button)
3509 map)
3510 'action (lambda (&rest ignore)
3511 (setq intero-help-entries
3512 (intero-bring-to-front intero-help-entries))
3513 (intero-help-refresh)))
3514 (insert " ")
3515 (insert-text-button
3516 "[forget]"
3517 'buffer (current-buffer)
3518 'keymap (let ((map (make-sparse-keymap)))
3519 (define-key map [mouse-1] 'push-button)
3520 map)
3521 'action (lambda (&rest ignore)
3522 (pop intero-help-entries)
3523 (intero-help-refresh)))
3524 (insert "\n\n"))))
3525
3526(defun intero-help-refresh ()
3527 "Refresh the help buffer with the current thing in the history."
3528 (interactive)
3529 (let ((buffer-read-only nil))
3530 (erase-buffer)
3531 (if (car intero-help-entries)
3532 (progn
3533 (intero-help-pagination)
3534 (insert (cdr (car intero-help-entries)))
3535 (goto-char (point-min)))
3536 (insert "No help entries."))))
3537
3538(defun intero-bring-to-front (xs)
3539 "Bring the last element of XS to the front."
3540 (cons (car (last xs)) (butlast xs)))
3541
3542(defun intero-help-push-history (buffer item)
3543 "Add (BUFFER . ITEM) to the history of help entries."
3544 (push (cons buffer item) intero-help-entries))
3545
3546(defun intero-help-info (ident)
3547 "Get the info of the thing with IDENT at point."
3548 (interactive (list (intero-ident-at-point)))
3549 (with-current-buffer (car (car intero-help-entries))
3550 (intero-info ident)))
3551
3552(define-derived-mode intero-help-mode help-mode "Intero-Help"
3553 "Help mode for intero."
3554 (setq buffer-read-only t)
3555 (setq intero-help-entries nil))
3556
3557(define-key intero-help-mode-map (kbd "g") 'intero-help-refresh)
3558(define-key intero-help-mode-map (kbd "C-c C-i") 'intero-help-info)
3559
3560;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3561;; Intero highlight uses mode
3562
3563(defvar intero-highlight-uses-mode-map
3564 (let ((map (make-sparse-keymap)))
3565 (define-key map (kbd "n") 'intero-highlight-uses-mode-next)
3566 (define-key map (kbd "TAB") 'intero-highlight-uses-mode-next)
3567 (define-key map (kbd "p") 'intero-highlight-uses-mode-prev)
3568 (define-key map (kbd "S-TAB") 'intero-highlight-uses-mode-prev)
3569 (define-key map (kbd "<backtab>") 'intero-highlight-uses-mode-prev)
3570 (define-key map (kbd "RET") 'intero-highlight-uses-mode-stop-here)
3571 (define-key map (kbd "r") 'intero-highlight-uses-mode-replace)
3572 (define-key map (kbd "q") 'intero-highlight-uses-mode)
3573 map)
3574 "Keymap for using `intero-highlight-uses-mode'.")
3575
3576(defvar-local intero-highlight-uses-mode-point nil)
3577(defvar-local intero-highlight-uses-buffer-old-mode nil)
3578
3579;;;###autoload
3580(define-minor-mode intero-highlight-uses-mode
3581 "Minor mode for highlighting and jumping between uses."
3582 :lighter " Uses"
3583 :keymap intero-highlight-uses-mode-map
3584 (if intero-highlight-uses-mode
3585 (progn (setq intero-highlight-uses-buffer-old-mode buffer-read-only)
3586 (setq buffer-read-only t)
3587 (setq intero-highlight-uses-mode-point (point)))
3588 (progn (setq buffer-read-only intero-highlight-uses-buffer-old-mode)
3589 (when intero-highlight-uses-mode-point
3590 (goto-char intero-highlight-uses-mode-point))))
3591 (remove-overlays (point-min) (point-max) 'intero-highlight-uses-mode-highlight t))
3592
3593(defun intero-highlight-uses-mode-replace ()
3594 "Replace all highlighted instances in the buffer with something else."
3595 (interactive)
3596 (save-excursion
3597 (goto-char (point-min))
3598 (let ((o (intero-highlight-uses-mode-next)))
3599 (when o
3600 (let ((replacement
3601 (read-from-minibuffer
3602 (format "Replace uses %s with: "
3603 (buffer-substring
3604 (overlay-start o)
3605 (overlay-end o))))))
3606 (let ((inhibit-read-only t))
3607 (while o
3608 (goto-char (overlay-start o))
3609 (delete-region (overlay-start o)
3610 (overlay-end o))
3611 (insert replacement)
3612 (setq o (intero-highlight-uses-mode-next))))))))
3613 (intero-highlight-uses-mode -1))
3614
3615(defun intero-highlight-uses-mode-stop-here ()
3616 "Stop at this point."
3617 (interactive)
3618 (setq intero-highlight-uses-mode-point (point))
3619 (intero-highlight-uses-mode -1))
3620
3621(defun intero-highlight-uses-mode-next ()
3622 "Jump to next result."
3623 (interactive)
3624 (let ((os (sort (cl-remove-if (lambda (o)
3625 (or (<= (overlay-start o) (point))
3626 (not (overlay-get o 'intero-highlight-uses-mode-highlight))))
3627 (overlays-in (point) (point-max)))
3628 (lambda (a b)
3629 (< (overlay-start a)
3630 (overlay-start b))))))
3631 (when os
3632 (mapc
3633 (lambda (o)
3634 (when (overlay-get o 'intero-highlight-uses-mode-highlight)
3635 (overlay-put o 'face 'lazy-highlight)))
3636 (overlays-in (line-beginning-position) (line-end-position)))
3637 (goto-char (overlay-start (car os)))
3638 (overlay-put (car os) 'face 'isearch)
3639 (car os))))
3640
3641(defun intero-highlight-uses-mode-prev ()
3642 "Jump to previous result."
3643 (interactive)
3644 (let ((os (sort (cl-remove-if (lambda (o)
3645 (or (>= (overlay-end o) (point))
3646 (not (overlay-get o 'intero-highlight-uses-mode-highlight))))
3647 (overlays-in (point-min) (point)))
3648 (lambda (a b)
3649 (> (overlay-start a)
3650 (overlay-start b))))))
3651 (when os
3652 (mapc
3653 (lambda (o)
3654 (when (overlay-get o 'intero-highlight-uses-mode-highlight)
3655 (overlay-put o 'face 'lazy-highlight)))
3656 (overlays-in (line-beginning-position) (line-end-position)))
3657 (goto-char (overlay-start (car os)))
3658 (overlay-put (car os) 'face 'isearch)
3659 (car os))))
3660
3661(defun intero-highlight-uses-mode-highlight (start end current)
3662 "Make a highlight overlay at the span from START to END.
3663If CURRENT, highlight the span uniquely."
3664 (let ((o (make-overlay start end)))
3665 (overlay-put o 'priority 999)
3666 (overlay-put o 'face
3667 (if current
3668 'isearch
3669 'lazy-highlight))
3670 (overlay-put o 'intero-highlight-uses-mode-highlight t)))
3671
3672;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3673
3674(provide 'intero)
3675
3676;;; intero.el ends here
generated by cgit v1.2.3 (git 2.39.1) at 2024-04-19 16:38:17 +0000