Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

329 lines (294 sloc) 13.743 kB
;;; 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
Jump to Line
Something went wrong with that request. Please try again.