-
Notifications
You must be signed in to change notification settings - Fork 342
/
inf-haskell.el
349 lines (312 loc) · 14.2 KB
/
inf-haskell.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
;;; inf-haskell.el --- Interaction with an inferior Haskell process.
;; Copyright (C) 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: Haskell
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; The code is made of 2 parts: a major mode for the buffer that holds the
;; inferior process's session and a minor mode for use in source buffers.
;;; Code:
(require 'comint)
(require 'shell) ;For directory tracking.
(require 'compile)
(require 'haskell-mode)
(eval-when-compile (require 'cl))
;; Here I depart from the inferior-haskell- prefix.
;; Not sure if it's a good idea.
(defcustom haskell-program-name
;; Arbitrarily give preference to hugs over ghci.
(or (cond
((not (fboundp 'executable-find)) nil)
((executable-find "hugs") "hugs \"+.\"")
((executable-find "ghci") "ghci"))
"hugs \"+.\"")
"The name of the command to start the inferior Haskell process.
The command can include arguments."
;; Custom only supports the :options keyword for a few types, e.g. not
;; for string.
;; :options '("hugs \"+.\"" "ghci")
:group 'haskell
:type '(choice string (repeat string)))
(defconst inferior-haskell-info-xref-re
"\t-- Defined at \\(.+\\):\\([0-9]+\\):\\([0-9]+\\)$")
(defconst inferior-haskell-error-regexp-alist
;; The format of error messages used by Hugs.
`(("^ERROR \"\\(.+?\\)\"\\(:\\| line \\)\\([0-9]+\\) - " 1 3)
;; Format of error messages used by GHCi.
("^\\(.+?\\):\\([0-9]+\\):\\(\\([0-9]+\\):\\)?\\( \\|\n +\\)\\(Warning\\)?"
1 2 4 ,@(if (fboundp 'compilation-fake-loc) '((6))))
;; Info xrefs.
,@(if (fboundp 'compilation-fake-loc)
`((,inferior-haskell-info-xref-re
1 2 3 0))))
"Regexps for error messages generated by inferior Haskell processes.
The format should be the same as for `compilation-error-regexp-alist'.")
(defcustom inferior-haskell-use-cabal t
"If non-nil, try and find a Cabal file to get the project root directory."
:type 'boolean)
(define-derived-mode inferior-haskell-mode comint-mode "Inf-Haskell"
"Major mode for interacting with an inferior Haskell process."
(set (make-local-variable 'comint-prompt-regexp)
"^\\*?[A-Z][\\._a-zA-Z0-9]*\\( \\*?[A-Z][\\._a-zA-Z0-9]*\\)*> ")
(set (make-local-variable 'comint-input-autoexpand) nil)
;; Setup directory tracking.
(set (make-local-variable 'shell-cd-regexp) ":cd")
(condition-case nil
(shell-dirtrack-mode 1)
(error ;The minor mode function may not exist or not accept an arg.
(set (make-local-variable 'shell-dirtrackp) t)
(add-hook 'comint-input-filter-functions 'shell-directory-tracker
nil 'local)))
;; Setup `compile' support so you can just use C-x ` and friends.
(set (make-local-variable 'compilation-error-regexp-alist)
inferior-haskell-error-regexp-alist)
(if (and (not (boundp 'minor-mode-overriding-map-alist))
(fboundp 'compilation-shell-minor-mode))
;; If we can't remove compilation-minor-mode bindings, at least try to
;; use compilation-shell-minor-mode, so there are fewer
;; annoying bindings.
(compilation-shell-minor-mode 1)
;; Else just use compilation-minor-mode but without its bindings because
;; things like mouse-2 are simply too annoying.
(compilation-minor-mode 1)
(let ((map (make-sparse-keymap)))
(dolist (keys '([menu-bar] [follow-link]))
;; Preserve some of the bindings.
(define-key map keys (lookup-key compilation-minor-mode-map keys)))
(add-to-list 'minor-mode-overriding-map-alist
(cons 'compilation-minor-mode map)))))
(defun inferior-haskell-string-to-strings (string)
"Split the STRING into a list of strings."
(let ((i (string-match "[\"]" string)))
(if (null i) (split-string string) ; no quoting: easy
(append (unless (eq i 0) (split-string (substring string 0 i)))
(let ((rfs (read-from-string string i)))
(cons (car rfs)
(inferior-haskell-string-to-strings
(substring string (cdr rfs)))))))))
(defun inferior-haskell-command (arg)
(inferior-haskell-string-to-strings
(if (null arg) haskell-program-name
(read-string "Command to run haskell: " haskell-program-name))))
(defvar inferior-haskell-buffer nil
"The buffer in which the inferior process is running.")
(defun inferior-haskell-start-process (command)
"Start an inferior haskell process.
With universal prefix \\[universal-argument], prompts for a COMMAND,
otherwise uses `haskell-program-name'.
It runs the hook `inferior-haskell-hook' after starting the process and
setting up the inferior-haskell buffer."
(interactive (list (inferior-haskell-command current-prefix-arg)))
(setq inferior-haskell-buffer
(apply 'make-comint "haskell" (car command) nil (cdr command)))
(with-current-buffer inferior-haskell-buffer
(inferior-haskell-mode)
(run-hooks 'inferior-haskell-hook)))
(defun inferior-haskell-process (&optional arg)
(or (if (buffer-live-p inferior-haskell-buffer)
(get-buffer-process inferior-haskell-buffer))
(progn
(let ((current-prefix-arg arg))
(call-interactively 'inferior-haskell-start-process))
;; Try again.
(inferior-haskell-process arg))))
;;;###autoload
(defalias 'run-haskell 'switch-to-haskell)
;;;###autoload
(defun switch-to-haskell (&optional arg)
"Show the inferior-haskell buffer. Start the process if needed."
(interactive "P")
(let ((proc (inferior-haskell-process arg)))
(pop-to-buffer (process-buffer proc))))
(eval-when-compile
(unless (fboundp 'with-selected-window)
(defmacro with-selected-window (win &rest body)
`(save-selected-window
(select-window ,win)
,@body))))
(defcustom inferior-haskell-wait-and-jump nil
"If non-nil, wait for file loading to terminate and jump to the error."
:type 'boolean
:group 'haskell)
(defun inferior-haskell-wait-for-prompt (proc)
"Wait until PROC sends us a prompt.
The process PROC should be associated to a comint buffer."
(with-current-buffer (process-buffer proc)
(while (progn
(goto-char comint-last-input-end)
(and (not (re-search-forward comint-prompt-regexp nil t))
(accept-process-output proc))))))
(defvar inferior-haskell-cabal-buffer nil)
(defun inferior-haskell-cabal-of-buf (buf)
(require 'haskell-cabal)
(with-current-buffer buf
(or inferior-haskell-cabal-buffer
(and (not (local-variable-p 'inferior-haskell-cabal-buffer))
(set (make-local-variable 'inferior-haskell-cabal-buffer)
(haskell-cabal-find-file))))))
;;;###autoload
(defun inferior-haskell-load-file (&optional reload)
"Pass the current buffer's file to the inferior haskell process."
(interactive)
;; Save first, so we're sure that `buffer-file-name' is non-nil afterward.
(save-buffer)
(let ((buf (current-buffer))
(file buffer-file-name)
(proc (inferior-haskell-process)))
(with-current-buffer (process-buffer proc)
(compilation-forget-errors)
(let ((parsing-end (marker-position (process-mark proc)))
cabal)
;; Go to the root of the Cabal project, if applicable.
(when (and inferior-haskell-use-cabal
(setq cabal (inferior-haskell-cabal-of-buf buf)))
;; Not sure if it's useful/needed and if it actually works.
(unless (equal default-directory
(with-current-buffer cabal default-directory))
(setq default-directory
(with-current-buffer cabal default-directory))
(inferior-haskell-send-command
proc (concat ":cd " default-directory)))
(setq file (file-relative-name file)))
(inferior-haskell-send-command
proc (if reload ":reload" (concat ":load \"" file "\"")))
;; Move the parsing-end marker after sending the command so
;; that it doesn't point just to the insertion point.
;; Otherwise insertion may move the marker (if done with
;; insert-before-markers) and we'd then miss some errors.
(if (boundp 'compilation-parsing-end)
(if (markerp compilation-parsing-end)
(set-marker compilation-parsing-end parsing-end)
(setq compilation-parsing-end parsing-end))))
(with-selected-window (display-buffer (current-buffer))
(goto-char (point-max)))
(when inferior-haskell-wait-and-jump
(inferior-haskell-wait-for-prompt proc)
(ignore-errors ;Don't beep if there were no errors.
(next-error))))))
(defun inferior-haskell-send-command (proc str)
(setq str (concat str "\n"))
(with-current-buffer (process-buffer proc)
(inferior-haskell-wait-for-prompt proc)
(goto-char (process-mark proc))
(insert-before-markers str)
(move-marker comint-last-input-end (point))
(comint-send-string proc str)))
(defun inferior-haskell-reload-file ()
"Tell the inferior haskell process to reread the current buffer's file."
(interactive)
(inferior-haskell-load-file 'reload))
(defun inferior-haskell-type (expr &optional insert-value)
"Query the haskell process for the type of the given expression.
If optional argument `insert-value' is non-nil, insert the type above point
in the buffer. This can be done interactively with the \\[universal-argument] prefix.
The returned info is cached for reuse by `haskell-doc-mode'."
(interactive
(let ((sym (haskell-ident-at-point)))
(list (read-string (if (> (length sym) 0)
(format "Show type of (default %s): " sym)
"Show type of: ")
nil nil sym)
current-prefix-arg)))
(if (string-match "\\`\\s_+\\'" expr) (setq expr (concat "(" expr ")")))
(let* ((proc (inferior-haskell-process))
(type
(with-current-buffer (process-buffer proc)
(let ((parsing-end ; Remember previous spot.
(marker-position (process-mark proc))))
(inferior-haskell-send-command proc (concat ":type " expr))
;; Find new point.
(goto-char (point-max))
(inferior-haskell-wait-for-prompt proc)
;; Back up to the previous end-of-line.
(end-of-line 0)
;; Extract the type output
(buffer-substring-no-properties
(save-excursion (goto-char parsing-end)
(line-beginning-position 2))
(point))))))
(if (not (string-match (concat "\\`" (regexp-quote expr) "[ \t]+::[ \t]*")
type))
(error "No type info: %s" type)
;; Cache for reuse by haskell-doc.
(when (and (boundp 'haskell-doc-mode) haskell-doc-mode
(boundp 'haskell-doc-user-defined-ids)
;; Haskell-doc only works for idents, not arbitrary expr.
(string-match "\\`(?\\(\\s_+\\|\\(\\sw\\|\\s'\\)+\\)?[ \t]*::[ \t]*"
type))
(let ((sym (match-string 1 type)))
(setq haskell-doc-user-defined-ids
(cons (cons sym (substring type (match-end 0)))
(remove-if (lambda (item) (equal (car item) sym))
haskell-doc-user-defined-ids)))))
(if (interactive-p) (message type))
(when insert-value
(beginning-of-line)
(insert type "\n"))
type)))
(defun inferior-haskell-info (sym)
"Query the haskell process for the info of the given expression."
(interactive
(let ((sym (haskell-ident-at-point)))
(list (read-string (if (> (length sym) 0)
(format "Show info of (default %s): " sym)
"Show info of: ")
nil nil sym))))
(let ((proc (inferior-haskell-process)))
(with-current-buffer (process-buffer proc)
(let ((parsing-end ; Remember previous spot.
(marker-position (process-mark proc))))
(inferior-haskell-send-command proc (concat ":info " sym))
;; Find new point.
(goto-char (point-max))
(inferior-haskell-wait-for-prompt proc)
;; Move to previous end-of-line
(end-of-line 0)
(let ((result
(buffer-substring-no-properties
(save-excursion (goto-char parsing-end)
(line-beginning-position 2))
(point))))
;; Move back to end of process buffer
(goto-char (point-max))
(if (interactive-p) (message "%s" result))
result)))))
(defun inferior-haskell-find-definition (sym)
"Attempt to locate and jump to the definition of the given expression."
(interactive
(let ((sym (haskell-ident-at-point)))
(list (read-string (if (> (length sym) 0)
(format "Find definition of (default %s): " sym)
"Find definition of: ")
nil nil sym))))
(let ((info (inferior-haskell-info sym)))
(if (not (string-match inferior-haskell-info-xref-re info))
(error "No source information available")
(let ((file (match-string-no-properties 1 info))
(line (string-to-number
(match-string-no-properties 2 info)))
(col (string-to-number
(match-string-no-properties 3 info))))
(when file
;; Push current location marker on the ring used by `find-tag'
(require 'etags)
(ring-insert find-tag-marker-ring (point-marker))
(pop-to-buffer (find-file-noselect file))
(when line
(goto-line line)
(when col (move-to-column col))))))))
(provide 'inf-haskell)
;; arch-tag: 61804287-63dd-4052-bc0e-90f691b34b40
;;; inf-haskell.el ends here