328 lines
13 KiB
EmacsLisp
328 lines
13 KiB
EmacsLisp
;;; 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'.")
|
|
|
|
(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 &optional separator)
|
|
"Split the STRING into a list of strings.
|
|
The SEPARATOR regexp defaults to \"\\s-+\"."
|
|
(let ((sep (or separator "\\s-+"))
|
|
(i (string-match "[\"]" string)))
|
|
(if (null i) (split-string string sep) ; no quoting: easy
|
|
(append (unless (eq i 0) (split-string (substring string 0 i) sep))
|
|
(let ((rfs (read-from-string string i)))
|
|
(cons (car rfs)
|
|
(inferior-haskell-string-to-strings
|
|
(substring string (cdr rfs)) sep)))))))
|
|
|
|
(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))))))
|
|
|
|
;;;###autoload
|
|
(defun inferior-haskell-load-file (&optional reload)
|
|
"Pass the current buffer's file to the inferior haskell process."
|
|
(interactive)
|
|
(let ((file buffer-file-name)
|
|
(proc (inferior-haskell-process)))
|
|
(save-buffer)
|
|
(with-current-buffer (process-buffer proc)
|
|
;; Not sure if it's useful/needed and if it actually works.
|
|
;; (unless (equal (file-name-as-directory default-directory)
|
|
;; (file-name-directory file))
|
|
;; (inferior-haskell-send-string
|
|
;; proc (concat ":cd " (file-name-directory file) "\n")))
|
|
(compilation-forget-errors)
|
|
(let ((parsing-end (marker-position (process-mark proc))))
|
|
(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
|