You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
838 lines
36 KiB
838 lines
36 KiB
9 years ago
|
;;; inf-haskell.el --- Interaction with an inferior Haskell process -*- lexical-binding: t -*-
|
||
|
|
|
||
|
|
;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009 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 3, 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 this program. If not, see <http://www.gnu.org/licenses/>.
|
||
|
|
|
||
|
|
;;; 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.
|
||
|
|
|
||
|
|
;; Todo:
|
||
|
|
|
||
|
|
;; - Check out Shim for ideas.
|
||
|
|
;; - i-h-load-buffer and i-h-send-region.
|
||
|
|
|
||
|
|
;;; Code:
|
||
|
|
|
||
|
|
(require 'comint)
|
||
|
|
(require 'shell) ; For directory tracking.
|
||
|
|
(require 'etags)
|
||
|
|
(require 'haskell-compat)
|
||
|
|
(require 'compile)
|
||
|
|
(require 'haskell-mode)
|
||
|
|
(require 'haskell-decl-scan)
|
||
|
|
(require 'haskell-cabal)
|
||
|
|
|
||
|
|
;; Dynamically scoped variables.
|
||
|
|
(defvar find-tag-marker-ring)
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defgroup inferior-haskell nil
|
||
|
|
"Settings for REPL interaction via `inferior-haskell-mode'"
|
||
|
|
:link '(custom-manual "(haskell-mode)inferior-haskell-mode")
|
||
|
|
:prefix "inferior-haskell-"
|
||
|
|
:prefix "haskell-"
|
||
|
|
:group 'haskell)
|
||
|
|
|
||
|
|
;; Here I depart from the inferior-haskell- prefix.
|
||
|
|
;; Not sure if it's a good idea.
|
||
|
|
;;;###autoload
|
||
|
|
(defcustom haskell-program-name
|
||
|
|
;; Arbitrarily give preference to hugs over ghci.
|
||
|
|
(or (cond
|
||
|
|
((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 'inferior-haskell
|
||
|
|
:type '(choice string (repeat string)))
|
||
|
|
|
||
|
|
(defconst inferior-haskell-info-xref-re
|
||
|
|
"\t-- Defined at \\(.+\\):\\([0-9]+\\):\\([0-9]+\\)\\(?:-\\([0-9]+\\)\\)?$")
|
||
|
|
|
||
|
|
(defconst inferior-haskell-module-re
|
||
|
|
"\t-- Defined in \\(.+\\)$"
|
||
|
|
"Regular expression for matching module names in :info.")
|
||
|
|
|
||
|
|
(defvar inferior-haskell-multiline-prompt-re
|
||
|
|
"^\\*?[[:upper:]][\\._[:alnum:]]*\\(?: \\*?[[:upper:]][\\._[:alnum:]]*\\)*| "
|
||
|
|
"Regular expression for matching multiline prompt (the one inside :{ ... :} blocks).")
|
||
|
|
|
||
|
|
(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) nil (5 '(face nil font-lock-multiline t)))))
|
||
|
|
;; Runtime exceptions, from ghci.
|
||
|
|
("^\\*\\*\\* Exception: \\(.+?\\):(\\([0-9]+\\),\\([0-9]+\\))-(\\([0-9]+\\),\\([0-9]+\\)): .*"
|
||
|
|
1 ,@(if (fboundp 'compilation-fake-loc) '((2 . 4) (3 . 5)) '(2 3)))
|
||
|
|
;; GHCi uses two different forms for line/col ranges, depending on
|
||
|
|
;; whether it's all on the same line or not :-( In Emacs-23, I could use
|
||
|
|
;; explicitly numbered subgroups to merge the two patterns.
|
||
|
|
("^\\*\\*\\* Exception: \\(.+?\\):\\([0-9]+\\):\\([0-9]+\\)-\\([0-9]+\\): .*"
|
||
|
|
1 2 ,(if (fboundp 'compilation-fake-loc) '(3 . 4) 3))
|
||
|
|
;; Info messages. Not errors per se.
|
||
|
|
,@(when (fboundp 'compilation-fake-loc)
|
||
|
|
`(;; Other GHCi patterns used in type errors.
|
||
|
|
("^[ \t]+at \\(.+\\):\\([0-9]+\\):\\([0-9]+\\)-\\([0-9]+\\)$"
|
||
|
|
1 2 (3 . 4) 0)
|
||
|
|
;; Foo.hs:318:80:
|
||
|
|
;; Ambiguous occurrence `Bar'
|
||
|
|
;; It could refer to either `Bar', defined at Zork.hs:311:5
|
||
|
|
;; or `Bar', imported from Bars at Frob.hs:32:0-16
|
||
|
|
;; (defined at Location.hs:97:5)
|
||
|
|
("[ (]defined at \\(.+\\):\\([0-9]+\\):\\([0-9]+\\))?$" 1 2 3 0)
|
||
|
|
("imported from .* at \\(.+\\):\\([0-9]+\\):\\([0-9]+\\)-\\([0-9]+\\)$"
|
||
|
|
1 2 (3 . 4) 0)
|
||
|
|
;; Info xrefs.
|
||
|
|
(,inferior-haskell-info-xref-re 1 2 (3 . 4) 0))))
|
||
|
|
"Regexps for error messages generated by inferior Haskell processes.
|
||
|
|
The format should be the same as for `compilation-error-regexp-alist'.")
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defcustom inferior-haskell-find-project-root t
|
||
|
|
"If non-nil, try and find the project root directory of this file.
|
||
|
|
This will either look for a Cabal file or a \"module\" statement in the file."
|
||
|
|
:group 'inferior-haskell
|
||
|
|
:type 'boolean)
|
||
|
|
|
||
|
|
(define-derived-mode inferior-haskell-mode comint-mode "Inf-Haskell"
|
||
|
|
"Major mode for interacting with an inferior Haskell process."
|
||
|
|
:group 'inferior-haskell
|
||
|
|
(set (make-local-variable 'comint-prompt-regexp)
|
||
|
|
;; Whay the backslash in [\\._[:alnum:]]?
|
||
|
|
"^\\*?[[:upper:]][\\._[:alnum:]]*\\(?: \\*?[[:upper:]][\\._[:alnum:]]*\\)*\\( λ\\)?> \\|^λ?> $")
|
||
|
|
(set (make-local-variable 'comint-input-autoexpand) nil)
|
||
|
|
(add-hook 'comint-preoutput-filter-functions
|
||
|
|
'inferior-haskell-send-decl-post-filter)
|
||
|
|
(add-hook 'comint-output-filter-functions 'inferior-haskell-spot-prompt nil t)
|
||
|
|
|
||
|
|
;; 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)
|
||
|
|
(set (make-local-variable 'compilation-first-column) 0) ;GHCI counts from 0.
|
||
|
|
(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))))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defcustom inferior-haskell-wait-and-jump nil
|
||
|
|
"If non-nil, wait for file loading to terminate and jump to the error."
|
||
|
|
:type 'boolean
|
||
|
|
:group 'inferior-haskell)
|
||
|
|
|
||
|
|
(defvar inferior-haskell-send-decl-post-filter-on nil)
|
||
|
|
(make-variable-buffer-local 'inferior-haskell-send-decl-post-filter-on)
|
||
|
|
|
||
|
|
(defun inferior-haskell-send-decl-post-filter (string)
|
||
|
|
(when (and inferior-haskell-send-decl-post-filter-on
|
||
|
|
#1=(string-match inferior-haskell-multiline-prompt-re string))
|
||
|
|
;; deleting sequence of `%s|' multiline promts
|
||
|
|
(while #1#
|
||
|
|
(setq string (substring string (match-end 0))))
|
||
|
|
;; deleting regular prompts
|
||
|
|
(setq string (replace-regexp-in-string comint-prompt-regexp "" string)
|
||
|
|
;; turning off this post-filter
|
||
|
|
inferior-haskell-send-decl-post-filter-on nil))
|
||
|
|
string)
|
||
|
|
|
||
|
|
(defvar inferior-haskell-seen-prompt nil)
|
||
|
|
(make-variable-buffer-local 'inferior-haskell-seen-prompt)
|
||
|
|
|
||
|
|
(defun inferior-haskell-spot-prompt (_string)
|
||
|
|
(let ((proc (get-buffer-process (current-buffer))))
|
||
|
|
(when proc
|
||
|
|
(save-excursion
|
||
|
|
(goto-char (process-mark proc))
|
||
|
|
(if (re-search-backward comint-prompt-regexp
|
||
|
|
(line-beginning-position) t)
|
||
|
|
(setq inferior-haskell-seen-prompt t))))))
|
||
|
|
|
||
|
|
(defun inferior-haskell-wait-for-prompt (proc &optional timeout)
|
||
|
|
"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)
|
||
|
|
(not (or inferior-haskell-seen-prompt
|
||
|
|
(setq inferior-haskell-seen-prompt
|
||
|
|
(re-search-forward comint-prompt-regexp nil t))
|
||
|
|
(not (accept-process-output proc timeout))))))
|
||
|
|
(unless inferior-haskell-seen-prompt
|
||
|
|
(error "Can't find the prompt"))))
|
||
|
|
|
||
|
|
(defvar inferior-haskell-cabal-buffer nil)
|
||
|
|
|
||
|
|
(defun inferior-haskell-cabal-of-buf (buf)
|
||
|
|
(with-current-buffer buf
|
||
|
|
(or (and (buffer-live-p inferior-haskell-cabal-buffer)
|
||
|
|
inferior-haskell-cabal-buffer)
|
||
|
|
(if (local-variable-p 'inferior-haskell-cabal-buffer
|
||
|
|
;; XEmacs needs this argument.
|
||
|
|
(current-buffer))
|
||
|
|
inferior-haskell-cabal-buffer
|
||
|
|
(set (make-local-variable 'inferior-haskell-cabal-buffer)
|
||
|
|
(haskell-cabal-find-file))))))
|
||
|
|
|
||
|
|
(defun inferior-haskell-find-project-root (buf)
|
||
|
|
(with-current-buffer buf
|
||
|
|
(let* (
|
||
|
|
(cabal-file (inferior-haskell-cabal-of-buf buf))
|
||
|
|
(cabal (when cabal-file
|
||
|
|
(find-file-noselect cabal-file)))
|
||
|
|
)
|
||
|
|
(or (when cabal
|
||
|
|
(with-current-buffer cabal
|
||
|
|
(let ((hsd (haskell-cabal-get-setting "hs-source-dirs")))
|
||
|
|
(if (null hsd)
|
||
|
|
;; If there's a Cabal file with no Hs-Source-Dirs, then
|
||
|
|
;; just use the Cabal file's directory.
|
||
|
|
default-directory
|
||
|
|
;; If there is an HSD, then check that it's an existing
|
||
|
|
;; dir (otherwise, it may be a list of dirs and we don't
|
||
|
|
;; know what to do with those). If it doesn't exist, then
|
||
|
|
;; give up.
|
||
|
|
(if (file-directory-p hsd) (expand-file-name hsd))))))
|
||
|
|
;; If there's no Cabal file or it's not helpful, try to look for
|
||
|
|
;; a "module" statement and count the number of "." in the
|
||
|
|
;; module name.
|
||
|
|
(save-excursion
|
||
|
|
(goto-char (point-min))
|
||
|
|
(let ((case-fold-search nil))
|
||
|
|
(when (re-search-forward
|
||
|
|
"^module[ \t]+\\(\\(?:\\sw\\|[.]\\)+\\)" nil t)
|
||
|
|
(let* ((dir default-directory)
|
||
|
|
(module (match-string 1))
|
||
|
|
(pos 0))
|
||
|
|
(while (string-match "\\." module pos)
|
||
|
|
(setq pos (match-end 0))
|
||
|
|
(setq dir (expand-file-name ".." dir)))
|
||
|
|
;; Let's check that the module name matches the file name,
|
||
|
|
;; otherwise the project root is probably not what we think.
|
||
|
|
(if (eq t (compare-strings
|
||
|
|
(file-name-sans-extension buffer-file-name)
|
||
|
|
nil nil
|
||
|
|
(expand-file-name
|
||
|
|
(replace-regexp-in-string "\\." "/" module)
|
||
|
|
dir)
|
||
|
|
nil nil t))
|
||
|
|
dir
|
||
|
|
;; If they're not equal, it means the local directory
|
||
|
|
;; hierarchy doesn't match the module name. This seems
|
||
|
|
;; odd, so let's warn the user about it. May help us
|
||
|
|
;; debug this code as well.
|
||
|
|
(message "Ignoring inconsistent `module' info: %s in %s"
|
||
|
|
module buffer-file-name)
|
||
|
|
nil)))))))))
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun inferior-haskell-load-file (&optional reload)
|
||
|
|
"Pass the current buffer's file to the inferior haskell process.
|
||
|
|
If prefix arg \\[universal-argument] is given, just reload the previous file."
|
||
|
|
(interactive "P")
|
||
|
|
;; 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)))
|
||
|
|
(if file
|
||
|
|
(with-current-buffer (process-buffer proc)
|
||
|
|
(compilation-forget-errors)
|
||
|
|
(let ((parsing-end (marker-position (process-mark proc)))
|
||
|
|
root)
|
||
|
|
;; Go to the root of the Cabal project, if applicable.
|
||
|
|
(when (and inferior-haskell-find-project-root
|
||
|
|
(setq root (inferior-haskell-find-project-root buf)))
|
||
|
|
;; Not sure if it's useful/needed and if it actually works.
|
||
|
|
(unless (equal default-directory root)
|
||
|
|
(setq default-directory root)
|
||
|
|
(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 \""
|
||
|
|
;; Espace the backslashes that may occur in file names.
|
||
|
|
(replace-regexp-in-string "[\\\"]" "\\\\\&" 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) nil 'visible)
|
||
|
|
(goto-char (point-max)))
|
||
|
|
;; Use compilation-auto-jump-to-first-error if available.
|
||
|
|
;; (if (and (boundp 'compilation-auto-jump-to-first-error)
|
||
|
|
;; compilation-auto-jump-to-first-error
|
||
|
|
;; (boundp 'compilation-auto-jump-to-next))
|
||
|
|
;; (setq compilation-auto-jump-to-next t)
|
||
|
|
(when inferior-haskell-wait-and-jump
|
||
|
|
(inferior-haskell-wait-for-prompt proc)
|
||
|
|
(ignore-errors ;Don't beep if there were no errors.
|
||
|
|
(next-error))))
|
||
|
|
(error "No file associated with buffer"))))
|
||
|
|
|
||
|
|
(defvar inferior-haskell-run-command ":main")
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun inferior-haskell-load-and-run (command)
|
||
|
|
"Pass the current buffer's file to haskell and then run a COMMAND."
|
||
|
|
(interactive
|
||
|
|
(list
|
||
|
|
(if (and inferior-haskell-run-command (not current-prefix-arg))
|
||
|
|
inferior-haskell-run-command
|
||
|
|
(read-string "Command to run: " nil nil inferior-haskell-run-command))))
|
||
|
|
(setq inferior-haskell-run-command command)
|
||
|
|
(let* ((inferior-haskell-errors nil)
|
||
|
|
(neh (lambda () (setq inferior-haskell-errors t))))
|
||
|
|
(unwind-protect
|
||
|
|
(let ((inferior-haskell-wait-and-jump t))
|
||
|
|
(add-hook 'next-error-hook neh)
|
||
|
|
(inferior-haskell-load-file))
|
||
|
|
(remove-hook 'next-error-hook neh))
|
||
|
|
(unless inferior-haskell-errors
|
||
|
|
(inferior-haskell-send-command (inferior-haskell-process) command)
|
||
|
|
(switch-to-haskell))))
|
||
|
|
|
||
|
|
(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))
|
||
|
|
(setq inferior-haskell-seen-prompt nil)
|
||
|
|
(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-wrap-decl (code)
|
||
|
|
"Wrap declaration code into :{ ... :}."
|
||
|
|
(setq code (concat code "\n"))
|
||
|
|
(concat ":{\n"
|
||
|
|
(if (string-match (concat "^\\s-*"
|
||
|
|
haskell-ds-start-keywords-re)
|
||
|
|
code)
|
||
|
|
;; non-fun-decl
|
||
|
|
code
|
||
|
|
;; fun-decl, wrapping into let { .. (; ..)* }
|
||
|
|
(concat "let {\n"
|
||
|
|
(mapconcat
|
||
|
|
;; adding 2 whitespaces to each line
|
||
|
|
(lambda (decl)
|
||
|
|
(mapconcat (lambda (s)
|
||
|
|
(concat " " s))
|
||
|
|
(split-string decl "\n")
|
||
|
|
"\n"))
|
||
|
|
;; splitting function case-decls
|
||
|
|
(let (decls)
|
||
|
|
(while (string-match "^\\(\\w+\\).*\n*\\(?:\\s-+.*\n+\\)*" code)
|
||
|
|
(push (match-string 0 code) decls)
|
||
|
|
(setq code (substring code (match-end 0))))
|
||
|
|
(reverse decls))
|
||
|
|
"\n;\n")
|
||
|
|
"\n}"))
|
||
|
|
"\n:}\n"))
|
||
|
|
|
||
|
|
(defun inferior-haskell-flash-decl (start end &optional timeout)
|
||
|
|
"Temporarily highlight declaration."
|
||
|
|
(let ((overlay (make-overlay start end)))
|
||
|
|
(overlay-put overlay 'face 'secondary-selection)
|
||
|
|
(run-with-timer (or timeout 0.2) nil 'delete-overlay overlay)))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun inferior-haskell-send-decl ()
|
||
|
|
"Send current declaration to inferior-haskell process."
|
||
|
|
(interactive)
|
||
|
|
(save-excursion
|
||
|
|
(goto-char (1+ (point)))
|
||
|
|
(let* ((proc (inferior-haskell-process))
|
||
|
|
(start (or (haskell-ds-backward-decl) (point-min)))
|
||
|
|
(end (or (haskell-ds-forward-decl) (point-max)))
|
||
|
|
(raw-decl (buffer-substring start end)))
|
||
|
|
;; enter multiline-prompt-cutting-mode
|
||
|
|
(with-current-buffer (process-buffer proc)
|
||
|
|
(setq inferior-haskell-send-decl-post-filter-on t))
|
||
|
|
;; flash decl
|
||
|
|
(inferior-haskell-flash-decl start end)
|
||
|
|
;; send decl
|
||
|
|
(comint-send-string proc (inferior-haskell-wrap-decl raw-decl))
|
||
|
|
;; send preview
|
||
|
|
(inferior-haskell-send-command
|
||
|
|
proc
|
||
|
|
(let* ((str (remove ?\n raw-decl))
|
||
|
|
(len (min 15 (length str))))
|
||
|
|
(concat "-- evaluating {: "
|
||
|
|
(substring str 0 len)
|
||
|
|
(if (= 15 len) ".." "")
|
||
|
|
" :}"))))))
|
||
|
|
|
||
|
|
(defun inferior-haskell-get-result (inf-expr)
|
||
|
|
"Submit the expression `inf-expr' to ghci and read the result."
|
||
|
|
(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 inf-expr)
|
||
|
|
;; Find new point.
|
||
|
|
(inferior-haskell-wait-for-prompt proc)
|
||
|
|
(goto-char (point-max))
|
||
|
|
;; Back up to the previous end-of-line.
|
||
|
|
(end-of-line 0)
|
||
|
|
;; Extract the output
|
||
|
|
(buffer-substring-no-properties
|
||
|
|
(save-excursion (goto-char parsing-end)
|
||
|
|
(line-beginning-position 2))
|
||
|
|
(point))))))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(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 sym
|
||
|
|
(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 ((type (inferior-haskell-get-result (concat ":type " expr))))
|
||
|
|
(if (not (string-match (concat "^\\(" (regexp-quote expr)
|
||
|
|
"[ \t\n]+\\(::\\|∷\\)[ \t\n]*\\(.\\|\n\\)*\\)")
|
||
|
|
type))
|
||
|
|
(error "No type info: %s" type)
|
||
|
|
(progn
|
||
|
|
(setf type (match-string 1 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)))
|
||
|
|
(delq (assoc sym haskell-doc-user-defined-ids)
|
||
|
|
haskell-doc-user-defined-ids)))))
|
||
|
|
|
||
|
|
(if (called-interactively-p 'any) (message "%s" type))
|
||
|
|
(when insert-value
|
||
|
|
(beginning-of-line)
|
||
|
|
(insert type "\n"))
|
||
|
|
type))))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun inferior-haskell-kind (type)
|
||
|
|
"Query the haskell process for the kind of the given expression."
|
||
|
|
(interactive
|
||
|
|
(let ((type (haskell-ident-at-point)))
|
||
|
|
(list (read-string (if type
|
||
|
|
(format "Show kind of (default %s): " type)
|
||
|
|
"Show kind of: ")
|
||
|
|
nil nil type))))
|
||
|
|
(let ((result (inferior-haskell-get-result (concat ":kind " type))))
|
||
|
|
(if (called-interactively-p 'any) (message "%s" result))
|
||
|
|
result))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(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 sym
|
||
|
|
(format "Show info of (default %s): " sym)
|
||
|
|
"Show info of: ")
|
||
|
|
nil nil sym))))
|
||
|
|
(let ((result (inferior-haskell-get-result (concat ":info " sym))))
|
||
|
|
(if (called-interactively-p 'any) (message "%s" result))
|
||
|
|
result))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(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 sym
|
||
|
|
(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
|
||
|
|
(with-current-buffer (process-buffer (inferior-haskell-process))
|
||
|
|
;; The file name is relative to the process's cwd.
|
||
|
|
(setq file (expand-file-name file)))
|
||
|
|
;; Push current location marker on the ring used by `find-tag'
|
||
|
|
(require 'etags)
|
||
|
|
(xref-push-marker-stack)
|
||
|
|
(pop-to-buffer (find-file-noselect file))
|
||
|
|
(when line
|
||
|
|
(goto-char (point-min))
|
||
|
|
(forward-line (1- line))
|
||
|
|
(when col (move-to-column col))))))))
|
||
|
|
|
||
|
|
;;; Functions to find the documentation of a given function.
|
||
|
|
;;
|
||
|
|
;; TODO for this section:
|
||
|
|
;;
|
||
|
|
;; * Support fetching of local Haddock docs pulled directly from source files.
|
||
|
|
;; * Display docs locally? w3m?
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defcustom inferior-haskell-use-web-docs
|
||
|
|
'fallback
|
||
|
|
"Whether to use the online documentation. Possible values:
|
||
|
|
`never', meaning always use local documentation, unless the local
|
||
|
|
file doesn't exist, when do nothing, `fallback', which means only
|
||
|
|
use the online documentation when the local file doesn't exist,
|
||
|
|
or `always', meaning always use the online documentation,
|
||
|
|
regardless of existance of local files. Default is `fallback'."
|
||
|
|
:group 'inferior-haskell
|
||
|
|
:type '(choice (const :tag "Never" never)
|
||
|
|
(const :tag "As fallback" fallback)
|
||
|
|
(const :tag "Always" always)))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defcustom inferior-haskell-web-docs-base
|
||
|
|
"http://haskell.org/ghc/docs/latest/html/libraries/"
|
||
|
|
"The base URL of the online libraries documentation.
|
||
|
|
This will only be used if the value of `inferior-haskell-use-web-docs'
|
||
|
|
is `always' or `fallback'."
|
||
|
|
:group 'inferior-haskell
|
||
|
|
:type 'string)
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defcustom haskell-package-manager-name "ghc-pkg"
|
||
|
|
"Name of the program to consult regarding package details."
|
||
|
|
:group 'inferior-haskell
|
||
|
|
:type 'string)
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defcustom haskell-package-conf-file
|
||
|
|
(condition-case nil
|
||
|
|
(with-temp-buffer
|
||
|
|
(call-process "ghc" nil t nil "--print-libdir")
|
||
|
|
(expand-file-name "package.conf"
|
||
|
|
(buffer-substring (point-min) (1- (point-max)))))
|
||
|
|
;; Don't use `ignore-errors' because this form is not byte-compiled :-(
|
||
|
|
(error nil))
|
||
|
|
"Where the package configuration file for the package manager resides.
|
||
|
|
By default this is set to `ghc --print-libdir`/package.conf."
|
||
|
|
:group 'inferior-haskell
|
||
|
|
:type 'string)
|
||
|
|
|
||
|
|
(defun inferior-haskell-get-module (sym)
|
||
|
|
"Fetch the module in which SYM is defined."
|
||
|
|
(let ((info (inferior-haskell-info sym)))
|
||
|
|
(unless (string-match inferior-haskell-module-re info)
|
||
|
|
(error
|
||
|
|
"No documentation information available. Did you forget to C-c C-l?"))
|
||
|
|
(let* ((module-name (match-string-no-properties 1 info))
|
||
|
|
(first-character (substring module-name 0 1)))
|
||
|
|
;; Handles GHC 7.4.1+ which quotes module names like
|
||
|
|
;; `System.Random', whereas previous GHC did not quote at all.
|
||
|
|
(if (or (string= "`" first-character) (string= "‘" first-character))
|
||
|
|
|
||
|
|
(substring module-name 1 (- (length module-name) 1))
|
||
|
|
module-name))))
|
||
|
|
|
||
|
|
(defun inferior-haskell-query-ghc-pkg (&rest args)
|
||
|
|
"Send ARGS to `haskell-package-manager-name'.
|
||
|
|
Insert the output into the current buffer."
|
||
|
|
(apply 'call-process haskell-package-manager-name nil t nil args))
|
||
|
|
|
||
|
|
(defun inferior-haskell-get-package-list ()
|
||
|
|
"Get the list of packages from `haskell-package-manager-name'."
|
||
|
|
(with-temp-buffer
|
||
|
|
(inferior-haskell-query-ghc-pkg "--simple-output" "list")
|
||
|
|
(split-string (buffer-substring (point-min) (point-max)))))
|
||
|
|
|
||
|
|
(defun inferior-haskell-compute-module-alist ()
|
||
|
|
"Compute a list mapping modules to package names and haddock URLs using ghc-pkg."
|
||
|
|
(message "Generating module alist...")
|
||
|
|
(let ((module-alist ()))
|
||
|
|
(with-temp-buffer
|
||
|
|
(dolist (package (inferior-haskell-get-package-list))
|
||
|
|
(erase-buffer)
|
||
|
|
(inferior-haskell-query-ghc-pkg "describe" package)
|
||
|
|
|
||
|
|
(let ((package-w/o-version
|
||
|
|
(replace-regexp-in-string "[-.0-9]*\\'" "" package))
|
||
|
|
;; Find the Haddock documentation URL for this package
|
||
|
|
(haddock
|
||
|
|
(progn
|
||
|
|
(goto-char (point-min))
|
||
|
|
(when (re-search-forward "haddock-html:[ \t]+\\(.*[^ \t\n]\\)"
|
||
|
|
nil t)
|
||
|
|
(match-string 1)))))
|
||
|
|
|
||
|
|
;; Fetch the list of exposed modules for this package
|
||
|
|
(goto-char (point-min))
|
||
|
|
(when (re-search-forward "^exposed-modules:\\(.*\\(\n[ \t].*\\)*\\)"
|
||
|
|
nil t)
|
||
|
|
(dolist (module (split-string (match-string 1)))
|
||
|
|
(push (list module package-w/o-version haddock)
|
||
|
|
module-alist)))))
|
||
|
|
|
||
|
|
(message "Generating module alist... done")
|
||
|
|
module-alist)))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defcustom inferior-haskell-module-alist-file
|
||
|
|
;; (expand-file-name "~/.inf-haskell-module-alist")
|
||
|
|
(expand-file-name (concat "inf-haskell-module-alist-"
|
||
|
|
(number-to-string (user-uid)))
|
||
|
|
temporary-file-directory)
|
||
|
|
"Where to save the module -> package lookup table.
|
||
|
|
Set this to nil to never cache to a file."
|
||
|
|
:group 'inferior-haskell
|
||
|
|
:type '(choice (const :tag "Don't cache to file" nil) string))
|
||
|
|
|
||
|
|
(defvar inferior-haskell-module-alist nil
|
||
|
|
"Association list of modules to their packages.
|
||
|
|
Each element is of the form (MODULE PACKAGE HADDOCK), where
|
||
|
|
MODULE is the name of a module,
|
||
|
|
PACKAGE is the package it belongs to, and
|
||
|
|
HADDOCK is the path to that package's Haddock documentation.
|
||
|
|
|
||
|
|
This is calculated on-demand using `inferior-haskell-compute-module-alist'.
|
||
|
|
It's also cached in the file `inferior-haskell-module-alist-file',
|
||
|
|
so that it can be obtained more quickly next time.")
|
||
|
|
|
||
|
|
(defun inferior-haskell-module-alist ()
|
||
|
|
"Get the module alist from cache or ghc-pkg's info."
|
||
|
|
(or
|
||
|
|
;; If we already have computed the alist, use it...
|
||
|
|
inferior-haskell-module-alist
|
||
|
|
(setq inferior-haskell-module-alist
|
||
|
|
(or
|
||
|
|
;; ...otherwise try to read it from the cache file...
|
||
|
|
(and
|
||
|
|
inferior-haskell-module-alist-file
|
||
|
|
(file-readable-p inferior-haskell-module-alist-file)
|
||
|
|
(file-newer-than-file-p inferior-haskell-module-alist-file
|
||
|
|
haskell-package-conf-file)
|
||
|
|
(with-temp-buffer
|
||
|
|
(insert-file-contents inferior-haskell-module-alist-file)
|
||
|
|
(goto-char (point-min))
|
||
|
|
(prog1 (read (current-buffer))
|
||
|
|
(message "Read module alist from file cache."))))
|
||
|
|
|
||
|
|
;; ...or generate it again and save it in a file for later.
|
||
|
|
(let ((alist (inferior-haskell-compute-module-alist)))
|
||
|
|
(when inferior-haskell-module-alist-file
|
||
|
|
(with-temp-buffer
|
||
|
|
(print alist (current-buffer))
|
||
|
|
;; Do the write to a temp file first, then rename it.
|
||
|
|
;; This makes it more atomic, and suffers from fewer security
|
||
|
|
;; holes related to race conditions if the file is in /tmp.
|
||
|
|
(let ((tmp (make-temp-file inferior-haskell-module-alist-file)))
|
||
|
|
(write-region (point-min) (point-max) tmp)
|
||
|
|
(rename-file tmp inferior-haskell-module-alist-file
|
||
|
|
'ok-if-already-exists))))
|
||
|
|
alist)))))
|
||
|
|
|
||
|
|
(defvar inferior-haskell-ghc-internal-ident-alist
|
||
|
|
;; FIXME: Fill this table, ideally semi-automatically.
|
||
|
|
'(("GHC.Base.return" . "Control.Monad.return")
|
||
|
|
("GHC.Base.String" . "Data.String.String")
|
||
|
|
("GHC.List" . "Data.List")))
|
||
|
|
|
||
|
|
(defun inferior-haskell-map-internal-ghc-ident (ident)
|
||
|
|
"Try to translate some internal GHC identifier to its alter ego in haskell docs."
|
||
|
|
(let ((head ident)
|
||
|
|
(tail "")
|
||
|
|
remapped)
|
||
|
|
(while (and (not
|
||
|
|
(setq remapped
|
||
|
|
(cdr (assoc head
|
||
|
|
inferior-haskell-ghc-internal-ident-alist))))
|
||
|
|
(string-match "\\.[^.]+\\'" head))
|
||
|
|
(setq tail (concat (match-string 0 head) tail))
|
||
|
|
(setq head (substring head 0 (match-beginning 0))))
|
||
|
|
(concat (or remapped head) tail)))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun inferior-haskell-find-haddock (sym)
|
||
|
|
"Find and open the Haddock documentation of SYM.
|
||
|
|
Make sure to load the file into GHCi or Hugs first by using C-c C-l.
|
||
|
|
Only works for functions in a package installed with ghc-pkg, or
|
||
|
|
whatever the value of `haskell-package-manager-name' is.
|
||
|
|
|
||
|
|
This function needs to find which package a given module belongs
|
||
|
|
to. In order to do this, it computes a module-to-package lookup
|
||
|
|
alist, which is expensive to compute (it takes upwards of five
|
||
|
|
seconds with more than about thirty installed packages). As a
|
||
|
|
result, we cache it across sessions using the cache file
|
||
|
|
referenced by `inferior-haskell-module-alist-file'. We test to
|
||
|
|
see if this is newer than `haskell-package-conf-file' every time
|
||
|
|
we load it."
|
||
|
|
(interactive
|
||
|
|
(let ((sym (haskell-ident-at-point)))
|
||
|
|
(list (read-string (if sym
|
||
|
|
(format "Find documentation of (default %s): " sym)
|
||
|
|
"Find documentation of: ")
|
||
|
|
nil nil sym))))
|
||
|
|
(let* (;; Find the module and look it up in the alist
|
||
|
|
(module (inferior-haskell-get-module sym))
|
||
|
|
(full-name (inferior-haskell-map-internal-ghc-ident (concat module "." sym)))
|
||
|
|
(_success (string-match "\\(.*\\)\\.\\(.*\\)" full-name))
|
||
|
|
(module (match-string 1 full-name))
|
||
|
|
(sym (match-string 2 full-name))
|
||
|
|
(alist-record (assoc module (inferior-haskell-module-alist)))
|
||
|
|
(package (nth 1 alist-record))
|
||
|
|
(file-name (concat (subst-char-in-string ?. ?- module) ".html"))
|
||
|
|
(local-path (concat (nth 2 alist-record) "/" file-name))
|
||
|
|
(url (if (or (eq inferior-haskell-use-web-docs 'always)
|
||
|
|
(and (not (file-exists-p local-path))
|
||
|
|
(eq inferior-haskell-use-web-docs 'fallback)))
|
||
|
|
(concat inferior-haskell-web-docs-base package "/" file-name)
|
||
|
|
(and (file-exists-p local-path)
|
||
|
|
(concat "file://" local-path))))
|
||
|
|
;; Jump to the symbol within Haddock.
|
||
|
|
(url (concat url "#v:" sym)))
|
||
|
|
(if url (browse-url url) (error "Local file doesn't exist"))))
|
||
|
|
|
||
|
|
(defvar inf-haskell-mode-map
|
||
|
|
(let ((map (make-sparse-keymap)))
|
||
|
|
;; (define-key map [?\M-C-x] 'inferior-haskell-send-defun)
|
||
|
|
;; (define-key map [?\C-x ?\C-e] 'inferior-haskell-send-last-sexp)
|
||
|
|
;; (define-key map [?\C-c ?\C-r] 'inferior-haskell-send-region)
|
||
|
|
(define-key map [?\C-x ?\C-d] 'inferior-haskell-send-decl)
|
||
|
|
(define-key map [?\C-c ?\C-z] 'switch-to-haskell)
|
||
|
|
(define-key map [?\C-c ?\C-l] 'inferior-haskell-load-file)
|
||
|
|
;; I think it makes sense to bind inferior-haskell-load-and-run to C-c
|
||
|
|
;; C-r, but since it used to be bound to `reload' until June 2007, I'm
|
||
|
|
;; going to leave it out for now.
|
||
|
|
;; (define-key map [?\C-c ?\C-r] 'inferior-haskell-load-and-run)
|
||
|
|
(define-key map [?\C-c ?\C-b] 'switch-to-haskell)
|
||
|
|
;; (define-key map [?\C-c ?\C-s] 'inferior-haskell-start-process)
|
||
|
|
;; That's what M-; is for.
|
||
|
|
(define-key map (kbd "C-c C-t") 'inferior-haskell-type)
|
||
|
|
(define-key map (kbd "C-c C-i") 'inferior-haskell-info)
|
||
|
|
(define-key map (kbd "C-c M-.") 'inferior-haskell-find-definition)
|
||
|
|
(define-key map (kbd "C-c C-d") 'inferior-haskell-find-haddock)
|
||
|
|
(define-key map [?\C-c ?\C-v] 'haskell-check)
|
||
|
|
map)
|
||
|
|
"Keymap for using inf-haskell.")
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(define-minor-mode inf-haskell-mode
|
||
|
|
"Minor mode for enabling inf-haskell process interaction."
|
||
|
|
:lighter " Inf-Haskell"
|
||
|
|
:keymap inf-haskell-mode-map)
|
||
|
|
|
||
|
|
(provide 'inf-haskell)
|
||
|
|
|
||
|
|
;;; inf-haskell.el ends here
|