diff options
Diffstat (limited to '.stack-work/install/x86_64-linux/lts-13.22/8.6.5/share')
2 files changed, 0 insertions, 3949 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/haskell-simple-indent.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/haskell-simple-indent.el deleted file mode 100644 index 1d43d23..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/haskell-simple-indent.el +++ /dev/null | |||
@@ -1,273 +0,0 @@ | |||
1 | ;;; haskell-simple-indent.el --- Simple indentation module for Haskell Mode -*- lexical-binding: t -*- | ||
2 | |||
3 | ;; Copyright (C) 1998 Heribert Schuetz, Graeme E Moss | ||
4 | |||
5 | ;; Author: Heribert Schuetz <Heribert.Schuetz@informatik.uni-muenchen.de> | ||
6 | ;; Graeme E Moss <gem@cs.york.ac.uk> | ||
7 | ;; Keywords: indentation files Haskell | ||
8 | |||
9 | ;; This file is not part of GNU Emacs. | ||
10 | |||
11 | ;; This file is free software; you can redistribute it and/or modify | ||
12 | ;; it under the terms of the GNU General Public License as published by | ||
13 | ;; the Free Software Foundation; either version 3, or (at your option) | ||
14 | ;; any later version. | ||
15 | |||
16 | ;; This file is distributed in the hope that it will be useful, | ||
17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
19 | ;; GNU General Public License for more details. | ||
20 | |||
21 | ;; You should have received a copy of the GNU General Public License | ||
22 | ;; along with this program. If not, see <http://www.gnu.org/licenses/>. | ||
23 | |||
24 | ;;; Commentary: | ||
25 | |||
26 | ;; Purpose: | ||
27 | ;; | ||
28 | ;; To support simple indentation of Haskell scripts. | ||
29 | ;; | ||
30 | ;; | ||
31 | ;; Installation: | ||
32 | ;; | ||
33 | ;; To bind TAB to the indentation command for all Haskell buffers, add | ||
34 | ;; this to .emacs: | ||
35 | ;; | ||
36 | ;; (add-hook 'haskell-mode-hook 'turn-on-haskell-simple-indent) | ||
37 | ;; | ||
38 | ;; Otherwise, call `turn-on-haskell-simple-indent'. | ||
39 | ;; | ||
40 | ;; | ||
41 | ;; Customisation: | ||
42 | ;; | ||
43 | ;; None supported. | ||
44 | ;; | ||
45 | ;; | ||
46 | ;; History: | ||
47 | ;; | ||
48 | ;; If you have any problems or suggestions, after consulting the list | ||
49 | ;; below, email gem@cs.york.ac.uk quoting the version of you are | ||
50 | ;; using, the version of Emacs you are using, and a small example of | ||
51 | ;; the problem or suggestion. | ||
52 | ;; | ||
53 | ;; Version 1.0: | ||
54 | ;; Brought over from Haskell mode v1.1. | ||
55 | ;; | ||
56 | ;; Present Limitations/Future Work (contributions are most welcome!): | ||
57 | ;; | ||
58 | ;; (None so far.) | ||
59 | |||
60 | ;;; Code: | ||
61 | |||
62 | ;; All functions/variables start with | ||
63 | ;; `(turn-(on/off)-)haskell-simple-indent'. | ||
64 | |||
65 | (require 'haskell-mode) | ||
66 | |||
67 | ;;;###autoload | ||
68 | (defgroup haskell-simple-indent nil | ||
69 | "Simple Haskell indentation." | ||
70 | :link '(custom-manual "(haskell-mode)Indentation") | ||
71 | :group 'haskell | ||
72 | :prefix "haskell-simple-indent-") | ||
73 | |||
74 | ;; Version. | ||
75 | (defconst haskell-simple-indent-version "1.2" | ||
76 | "`haskell-simple-indent' version number.") | ||
77 | (defun haskell-simple-indent-version () | ||
78 | "Echo the current version of `haskell-simple-indent' in the minibuffer." | ||
79 | (interactive) | ||
80 | (message "Using haskell-simple-indent version %s" | ||
81 | haskell-simple-indent-version)) | ||
82 | |||
83 | ;; Partly stolen from `indent-relative' in indent.el: | ||
84 | (defun haskell-simple-indent () | ||
85 | "Space out to under next visible indent point. | ||
86 | |||
87 | Indent points are positions of non-whitespace following | ||
88 | whitespace in lines preceeding point. Example: | ||
89 | |||
90 | func arg cx = when (isTrue) $ do | ||
91 | print 42 | ||
92 | ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ | ||
93 | |||
94 | A position is visible if it is to the left of the first | ||
95 | non-whitespace (indentation) of every nonblank line between the | ||
96 | position and the current line. If there is no visible indent | ||
97 | point beyond the current column, position given by | ||
98 | `indent-next-tab-stop' is used instead." | ||
99 | (interactive) | ||
100 | (let* ((start-column (or (save-excursion | ||
101 | (back-to-indentation) | ||
102 | (if (not (eolp)) | ||
103 | (current-column))) | ||
104 | (current-column))) | ||
105 | (invisible-from nil) ; `nil' means infinity here | ||
106 | (found) | ||
107 | (indent)) | ||
108 | (save-excursion | ||
109 | ;; Loop stops if there no more lines above this one or when has | ||
110 | ;; found a line starting at first column. | ||
111 | (while (and (not found) | ||
112 | (or (not invisible-from) | ||
113 | (not (zerop invisible-from))) | ||
114 | (zerop (forward-line -1))) | ||
115 | ;; Ignore empty lines. | ||
116 | (if (not (looking-at "[ \t]*\n")) | ||
117 | (let ((this-indentation (current-indentation))) | ||
118 | ;; Is this line so indented that it cannot have | ||
119 | ;; influence on indentation points? | ||
120 | (if (or (not invisible-from) | ||
121 | (< this-indentation invisible-from)) | ||
122 | (if (> this-indentation start-column) | ||
123 | (setq invisible-from this-indentation) | ||
124 | (let ((end (line-end-position))) | ||
125 | (move-to-column start-column) | ||
126 | ;; Is start-column inside a tab on this line? | ||
127 | (if (> (current-column) start-column) | ||
128 | (backward-char 1)) | ||
129 | ;; Skip to the end of non-whitespace. | ||
130 | (skip-chars-forward "^ \t" end) | ||
131 | ;; Skip over whitespace. | ||
132 | (skip-chars-forward " \t" end) | ||
133 | ;; Indentation point found if not at the end of | ||
134 | ;; line and if not covered by any line below | ||
135 | ;; this one. In that case use invisible-from. | ||
136 | (setq indent (if (or (= (point) end) | ||
137 | (and invisible-from | ||
138 | (> (current-column) invisible-from))) | ||
139 | invisible-from | ||
140 | (current-column))) | ||
141 | ;; Signal that solution is found. | ||
142 | (setq found t)))))))) | ||
143 | |||
144 | |||
145 | (let ((opoint (point-marker))) | ||
146 | ;; Indent to the calculated indent or last know invisible-from | ||
147 | ;; or use tab-to-tab-stop. Try hard to keep cursor in the same | ||
148 | ;; place or move it to the indentation if it was before it. And | ||
149 | ;; keep content of the line intact. | ||
150 | (setq indent (or indent | ||
151 | invisible-from | ||
152 | (if (fboundp 'indent-next-tab-stop) | ||
153 | (indent-next-tab-stop start-column)) | ||
154 | (let ((tabs tab-stop-list)) | ||
155 | (while (and tabs (>= start-column (car tabs))) | ||
156 | (setq tabs (cdr tabs))) | ||
157 | (if tabs (car tabs))) | ||
158 | (* (/ (+ start-column tab-width) tab-width) tab-width))) | ||
159 | (indent-line-to indent) | ||
160 | (if (> opoint (point)) | ||
161 | (goto-char opoint)) | ||
162 | (set-marker opoint nil)))) | ||
163 | |||
164 | (defun haskell-simple-indent-backtab () | ||
165 | "Indent backwards. Dual to `haskell-simple-indent'." | ||
166 | (interactive) | ||
167 | (let ((saved-column (or (save-excursion | ||
168 | (back-to-indentation) | ||
169 | (if (not (eolp)) | ||
170 | (current-column))) | ||
171 | (current-column))) | ||
172 | (i 0) | ||
173 | (x 0)) | ||
174 | |||
175 | (save-excursion | ||
176 | (back-to-indentation) | ||
177 | (delete-region (line-beginning-position) (point))) | ||
178 | (while (< (or (save-excursion | ||
179 | (back-to-indentation) | ||
180 | (if (not (eolp)) | ||
181 | (current-column))) | ||
182 | (current-column)) saved-column) | ||
183 | (haskell-simple-indent) | ||
184 | (setq i (+ i 1))) | ||
185 | |||
186 | (save-excursion | ||
187 | (back-to-indentation) | ||
188 | (delete-region (line-beginning-position) (point))) | ||
189 | (while (< x (- i 1)) | ||
190 | (haskell-simple-indent) | ||
191 | (setq x (+ x 1))))) | ||
192 | |||
193 | (defun haskell-simple-indent-newline-same-col () | ||
194 | "Make a newline and go to the same column as the current line." | ||
195 | (interactive) | ||
196 | (let ((start-end | ||
197 | (save-excursion | ||
198 | (let* ((start (line-beginning-position)) | ||
199 | (end (progn (goto-char start) | ||
200 | (search-forward-regexp | ||
201 | "[^ ]" (line-end-position) t 1)))) | ||
202 | (when end (cons start (1- end))))))) | ||
203 | (if start-end | ||
204 | (progn (newline) | ||
205 | (insert (buffer-substring-no-properties | ||
206 | (car start-end) (cdr start-end)))) | ||
207 | (newline)))) | ||
208 | |||
209 | (defun haskell-simple-indent-newline-indent () | ||
210 | "Make a newline on the current column and indent on step." | ||
211 | (interactive) | ||
212 | (haskell-simple-indent-newline-same-col) | ||
213 | (insert (make-string haskell-indent-spaces ? ))) | ||
214 | |||
215 | (defun haskell-simple-indent-comment-indent-function () | ||
216 | "Haskell version of `comment-indent-function'." | ||
217 | ;; This is required when filladapt is turned off. Without it, when | ||
218 | ;; filladapt is not used, comments which start in column zero | ||
219 | ;; cascade one character to the right | ||
220 | (save-excursion | ||
221 | (beginning-of-line) | ||
222 | (let ((eol (line-end-position))) | ||
223 | (and comment-start-skip | ||
224 | (re-search-forward comment-start-skip eol t) | ||
225 | (setq eol (match-beginning 0))) | ||
226 | (goto-char eol) | ||
227 | (skip-chars-backward " \t") | ||
228 | (max comment-column (+ (current-column) (if (bolp) 0 1)))))) | ||
229 | |||
230 | ;;;###autoload | ||
231 | (define-minor-mode haskell-simple-indent-mode | ||
232 | "Simple Haskell indentation mode that uses simple heuristic. | ||
233 | In this minor mode, `indent-for-tab-command' (bound to <tab> by | ||
234 | default) will move the cursor to the next indent point in the | ||
235 | previous nonblank line, whereas `haskell-simple-indent-backtab' | ||
236 | \ (bound to <backtab> by default) will move the cursor the | ||
237 | previous indent point. An indent point is a non-whitespace | ||
238 | character following whitespace. | ||
239 | |||
240 | Runs `haskell-simple-indent-hook' on activation." | ||
241 | :lighter " Ind" | ||
242 | :group 'haskell-simple-indent | ||
243 | :keymap '(([backtab] . haskell-simple-indent-backtab)) | ||
244 | (kill-local-variable 'comment-indent-function) | ||
245 | (kill-local-variable 'indent-line-function) | ||
246 | (when haskell-simple-indent-mode | ||
247 | (when (and (bound-and-true-p haskell-indentation-mode) | ||
248 | (fboundp 'haskell-indentation-mode)) | ||
249 | (haskell-indentation-mode 0)) | ||
250 | (set (make-local-variable 'comment-indent-function) #'haskell-simple-indent-comment-indent-function) | ||
251 | (set (make-local-variable 'indent-line-function) 'haskell-simple-indent) | ||
252 | (run-hooks 'haskell-simple-indent-hook))) | ||
253 | |||
254 | ;; The main functions. | ||
255 | ;;;###autoload | ||
256 | (defun turn-on-haskell-simple-indent () | ||
257 | "Turn on function `haskell-simple-indent-mode'." | ||
258 | (interactive) | ||
259 | (haskell-simple-indent-mode)) | ||
260 | (make-obsolete 'turn-on-haskell-simple-indent | ||
261 | 'haskell-simple-indent-mode | ||
262 | "2015-07-23") | ||
263 | |||
264 | (defun turn-off-haskell-simple-indent () | ||
265 | "Turn off function `haskell-simple-indent-mode'." | ||
266 | (interactive) | ||
267 | (haskell-simple-indent-mode 0)) | ||
268 | |||
269 | ;; Provide ourselves: | ||
270 | |||
271 | (provide 'haskell-simple-indent) | ||
272 | |||
273 | ;;; haskell-simple-indent.el ends here | ||
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 | |||
80 | This version does not necessarily have to be the latest version | ||
81 | of intero published on Hackage. Sometimes there are changes to | ||
82 | Intero which have no use for the Emacs mode. It is only bumped | ||
83 | when the Emacs mode actually requires newer features from the | ||
84 | intero executable, otherwise we force our users to upgrade | ||
85 | pointlessly." | ||
86 | :group 'intero | ||
87 | :type 'string) | ||
88 | |||
89 | (defcustom intero-repl-no-load | ||
90 | t | ||
91 | "Pass --no-load when starting the repl. | ||
92 | This 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. | ||
99 | This 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 | |||
112 | It should be a list of directories. | ||
113 | |||
114 | To use this, use the following mode hook: | ||
115 | (add-hook 'haskell-mode-hook 'intero-mode-whitelist) | ||
116 | or 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 | |||
124 | It should be a list of directories. | ||
125 | |||
126 | To use this, use the following mode hook: | ||
127 | (add-hook 'haskell-mode-hook 'intero-mode-blacklist) | ||
128 | or 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 | |||
147 | For example, this variable can be used to run intero with extra | ||
148 | warnings 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 | |||
155 | For example, this variable can be used to enable some ghci extensions | ||
156 | by 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. | ||
235 | The buffer's filename (or working directory) is checked against | ||
236 | `intero-whitelist' and `intero-blacklist'. If both the whitelist | ||
237 | and 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. | ||
244 | The buffer's filename (or working directory) is checked against | ||
245 | `intero-whitelist' and `intero-blacklist'. If both the whitelist | ||
246 | and 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. | ||
276 | LIST 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. | ||
322 | A true value indicates that the backend could not start, or could | ||
323 | not be installed. The user will have to manually run | ||
324 | `intero-restart' or `intero-targets' to destroy the buffer and | ||
325 | create a fresh one without this variable enabled.") | ||
326 | |||
327 | (defvar-local intero-try-with-build nil | ||
328 | "Try starting intero without --no-build. | ||
329 | This 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 | |||
394 | You 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 | |||
467 | With prefix argument INSERT, inserts the type above the current | ||
468 | line 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. | ||
525 | Returns 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. | ||
545 | If 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. | ||
625 | When SAVE-DIR-LOCAL is non-nil, save TARGETS as the | ||
626 | directory-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. | ||
640 | Intero will be restarted with the new configuration. When | ||
641 | SAVE-DIR-LOCAL is non-nil, save FILE as the directory-local value | ||
642 | for `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. | ||
661 | If 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 | |||
673 | This is for doing live update of the code of servers or GUI | ||
674 | applications. Put your development version of the program in | ||
675 | `DevelMain', and define `update' to auto-start the program on a | ||
676 | new thread, and use the `foreign-store' package to access the | ||
677 | running 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 | ||
769 | process." | ||
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. | ||
778 | CHECKER 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'. | ||
890 | Should 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. | ||
924 | Other 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. | ||
991 | If specified, MINLEN is the shortest completion which will be | ||
992 | considered." | ||
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. | ||
1048 | Returns a list of form '(prefix-start-position | ||
1049 | prefix-end-position prefix-value prefix-type) for pramga names | ||
1050 | such as WARNING, DEPRECATED, LANGUAGE etc. Also returns | ||
1051 | completion prefixes for options in case OPTIONS_GHC pragma, or | ||
1052 | language extensions in case of LANGUAGE pragma. Obsolete OPTIONS | ||
1053 | pragma 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 | ||
1150 | that 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'. | ||
1162 | This is not for saving on requests (we make a request even if | ||
1163 | something is in cache, overwriting the old entry), but rather for | ||
1164 | making 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. | ||
1168 | Like `eldoc-print-current-symbol-info', but just printing MSG | ||
1169 | instead 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. | ||
1201 | Returns 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. | ||
1240 | This 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. | ||
1250 | The REPL will be started if necessary, and the REPL buffer will | ||
1251 | be 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. | ||
1275 | If 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. | ||
1302 | If the region is unset, the current line will be used. | ||
1303 | PROMPT-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. | ||
1316 | If 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. | ||
1341 | If PROMPT-OPTIONS is non-nil, prompt with an options list. When | ||
1342 | STORE-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. | ||
1396 | BACKEND-BUFFER is used for options. TARGETS is the targets to | ||
1397 | load. If PROMPT-OPTIONS is non-nil, prompt with an options list. | ||
1398 | STACK-YAML is the stack yaml config to use. When nil, tries to | ||
1399 | use project-wide intero-stack-yaml when nil, otherwise uses | ||
1400 | stack'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. | ||
1456 | Default options come from user customization and any temporary | ||
1457 | changes 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. | ||
1520 | May 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. | ||
1527 | Returns nil if no identifier found or point is inside string or | ||
1528 | comment. 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. | ||
1613 | Expects point stands *after* delimiting dot. | ||
1614 | Returns 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. | ||
1629 | CHAR is a chararacter that is assumed to be the first character | ||
1630 | of 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. | ||
1656 | The 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. | ||
1724 | PREFIX, DIR-FLAG and SUFFIX are all passed to `make-temp-file' | ||
1725 | unmodified. A different directory is applied so that if docker | ||
1726 | is used with stack, the commands run inside docker can find the | ||
1727 | path." | ||
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. | ||
1782 | This 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. | ||
1789 | Path names are standardised and drive names are | ||
1790 | capitalized (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. | ||
1795 | This applies to paths of the form | ||
1796 | x:\\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. | ||
1836 | CONT is called within the current buffer, with BEG, END and the | ||
1837 | type 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. | ||
1992 | Prefix is marked by positions BEG and END. Completions are | ||
1993 | passed 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. | ||
2026 | Completions 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. | ||
2046 | INFILE, 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 | ||
2049 | machine, 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'. | ||
2055 | INFILE, DESTINATION, DISPLAY and ARGS are as for | ||
2056 | `call-process'/`process-file'. STACK-YAML specifies which stack | ||
2057 | yaml 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. | ||
2103 | The result, along with the given STATE, is passed to CALLBACK | ||
2104 | as (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. | ||
2169 | The result, along with the given STATE, is passed to CALLBACK | ||
2170 | as (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. | ||
2200 | If 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. | ||
2211 | INSTALL-STATUS indicates the current installation status. | ||
2212 | If 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. | ||
2227 | Use the given TARGETS, SOURCE-BUFFER and STACK-YAML." | ||
2228 | (let ((ghc-version (intero-ghc-version-raw))) | ||
2229 | (insert | ||
2230 | (format " | ||
2231 | |||
2232 | Installing 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 | |||
2254 | We don't know why it failed. Please read the above output and try | ||
2255 | installing manually. If that doesn't work, report this as a | ||
2256 | problem. | ||
2257 | |||
2258 | Guess: You might need the \"tinfo\" package, e.g. libtinfo-dev. | ||
2259 | |||
2260 | WHAT TO DO NEXT | ||
2261 | |||
2262 | If you don't want to Intero to try installing itself again for | ||
2263 | this project, just keep this buffer around in your Emacs. | ||
2264 | |||
2265 | If you'd like to try again next time you try use an Intero | ||
2266 | feature, 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. | ||
2273 | Use the given TARGETS, SOURCE-BUFFER and STACK-YAML." | ||
2274 | (insert | ||
2275 | " | ||
2276 | |||
2277 | Installing 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 | |||
2303 | We don't know why it failed. Please read the above output and try | ||
2304 | installing manually. If that doesn't work, report this as a | ||
2305 | problem. | ||
2306 | |||
2307 | WHAT TO DO NEXT | ||
2308 | |||
2309 | If you don't want to Intero to try installing itself again for | ||
2310 | this project, just keep this buffer around in your Emacs. | ||
2311 | |||
2312 | If you'd like to try again next time you try use an Intero | ||
2313 | feature, 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. | ||
2320 | Uses the specified TARGETS if supplied. | ||
2321 | Automatically performs initial actions in SOURCE-BUFFER, if specified. | ||
2322 | Uses 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. | ||
2390 | Uses the specified TARGETS if supplied. | ||
2391 | Uses 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. | ||
2418 | Restarts 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. | ||
2425 | TARGETS are the build targets. When non-nil, NO-BUILD and | ||
2426 | NO-LOAD enable the correspondingly-named stack options. When | ||
2427 | IGNORE-DOT-GHCI is non-nil, it enables the corresponding GHCI | ||
2428 | option. STACK-YAML is the stack config file to use (or stack's | ||
2429 | default 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. | ||
2447 | This 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, | ||
2512 | but a problem occcured. | ||
2513 | |||
2514 | TROUBLESHOOTING | ||
2515 | |||
2516 | It may be obvious if there is some text above this message | ||
2517 | indicating a problem. | ||
2518 | |||
2519 | If you do not wish to use Intero for some projects, see | ||
2520 | https://github.com/commercialhaskell/intero#whitelistingblacklisting-projects | ||
2521 | |||
2522 | The 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 | |||
2536 | It's worth checking that the correct stack executable is being | ||
2537 | found 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 | |||
2544 | WHAT TO DO NEXT | ||
2545 | |||
2546 | If you fixed the problem, just kill this buffer, Intero will make | ||
2547 | a fresh one and attempt to start the process automatically as | ||
2548 | soon as you start editing code again. | ||
2549 | |||
2550 | If you are unable to fix the problem, just leave this buffer | ||
2551 | around in Emacs and Intero will not attempt to start the process | ||
2552 | anymore. | ||
2553 | |||
2554 | You 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. | ||
2585 | Uses 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. | ||
2626 | This is the directory where the file specified in | ||
2627 | `intero-stack-yaml' is located, or if nil then the directory | ||
2628 | where stack.yaml is placed for this project, or the global one if | ||
2629 | no 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 | |||
2643 | This can be caused by a syntax error in your stack.yaml file. Check that out. | ||
2644 | |||
2645 | If you do not wish to use Intero for some projects, see | ||
2646 | https://github.com/commercialhaskell/intero#whitelistingblacklisting-projects | ||
2647 | |||
2648 | Otherwise, please report this as a bug! | ||
2649 | |||
2650 | For 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. | ||
2717 | If there is none, return an empty string. If specified, use | ||
2718 | CABAL-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. | ||
2731 | If DIR is nil, `default-directory' is used as starting point for | ||
2732 | directory traversal. Upward traversal is aborted if file owner | ||
2733 | changes. 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. | ||
2756 | Returns nil if none or multiple \".cabal\" files were found. If | ||
2757 | ALLOW-MULTIPLE is non nil, in case of multiple \".cabal\" files, | ||
2758 | a 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. | ||
2785 | Each 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. | ||
2844 | If running, otherwise returns nil. | ||
2845 | |||
2846 | It is the responsibility of the caller to make sure the server is | ||
2847 | running; the user might not want to start the server | ||
2848 | automatically." | ||
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 | |||
2951 | This may update in-place the MSGS objects to hint that | ||
2952 | suggestions 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...). | ||
3474 | Equivalent 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. | ||
3663 | If 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 | ||