;;; inf-haskell.el --- Interaction with an inferior Haskell process -*- lexical-binding: t -*-
;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
;; Copyright (C) 2017 Vasantha Ganesh Kanniappan <vasanthaganesh.k@tuta.io>
;; 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:
;; A major mode for the buffer that holds the inferior process
;; 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-decl-scan)
(require 'haskell-cabal)
(require 'haskell-customize)
(require 'cl-lib)
(require 'haskell-string)
;;;###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)
(defcustom inferior-haskell-hook nil
"The hook that is called after starting inf-haskell."
:type 'hook)
(defun haskell-program-name-with-args ()
"Return the command with the arguments to start the repl based on the
directory structure."
(cl-ecase (haskell-process-type)
('ghci (cond ((eq system-type 'cygwin) (nconc "ghcii.sh"
haskell-process-args-ghci))
(t (append
(if (listp haskell-process-path-ghci)
haskell-process-path-ghci
(list haskell-process-path-ghci))
haskell-process-args-ghci))))
('cabal-repl (nconc `(,haskell-process-path-cabal
"repl")
haskell-process-args-cabal-repl))
('stack-ghci (nconc `(,haskell-process-path-stack
"ghci")
haskell-process-args-stack-ghci))))
(defconst inferior-haskell-info-xref-re
"-- Defined at \\(.+\\):\\([0-9]+\\):\\([0-9]+\\)\\(?:-\\([0-9]+\\)\\)?$")
(defconst inferior-haskell-module-re
"-- 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
`(;; Format of error messages used by GHCi.
("^\\(.+?\\):\\([0-9]+\\):\\(\\([0-9]+\\):\\)?\\( \\|\n *\\)\\([Ww]arning\\)?"
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'.")
(defconst haskell-prompt-regexp
;; Why the backslash in [\\._[:alnum:]]?
"^\\*?[[:upper:]][\\._[:alnum:]]*\\(?: \\*?[[:upper:]][\\._[:alnum:]]*\\)*\\( λ\\)?> \\|^λ?> $")
;;; TODO
;;; -> Make font lock work for strings, directories, hyperlinks
;;; -> Make font lock work for key words???
(defvar inf-haskell-map
(let ((map (make-sparse-keymap)))
(define-key map "\C-c\C-d" 'comint-kill-subjob)
map))
(defvaralias 'inferior-haskell-mode-map 'inf-haskell-map)
(define-derived-mode inferior-haskell-mode comint-mode "Inf-Haskell"
"Major mode for interacting with an inferior Haskell process."
:group 'inferior-haskell
(setq-local comint-prompt-regexp haskell-prompt-regexp)
(setq-local paragraph-start haskell-prompt-regexp)
(setq-local comint-input-autoexpand nil)
(setq-local comint-prompt-read-only t)
;; Setup directory tracking.
(setq-local shell-cd-regexp ":cd")
(condition-case nil
(shell-dirtrack-mode 1)
(error ;The minor mode function may not exist or not accept an arg.
(setq-local 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.
(setq-local compilation-error-regexp-alist inferior-haskell-error-regexp-alist)
(setq-local 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))))
(add-hook 'inferior-haskell-hook 'inferior-haskell-init))
(defvar inferior-haskell-buffer nil
"The buffer in which the inferior process is running.")
(defun inferior-haskell-start-process ()
"Start an inferior haskell process.
With universal prefix \\[universal-argument], prompts for a COMMAND,
otherwise uses `haskell-program-name-with-args'.
It runs the hook `inferior-haskell-hook' after starting the process and
setting up the inferior-haskell buffer."
(let ((command (haskell-program-name-with-args)))
(setq default-directory inferior-haskell-root-dir)
(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 ()
"Restart if not present."
(cond ((and (buffer-live-p inferior-haskell-buffer)
(comint-check-proc inferior-haskell-buffer))
(get-buffer-process inferior-haskell-buffer))
(t (inferior-haskell-start-process)
(inferior-haskell-process))))
;;;###autoload
(defalias 'run-haskell 'switch-to-haskell)
;;;###autoload
(defun switch-to-haskell ()
"Show the inferior-haskell buffer. Start the process if needed."
(interactive)
(let ((proc (inferior-haskell-process)))
(pop-to-buffer-same-window (process-buffer proc))))
(defvar inferior-haskell-result-history nil)
(defvar haskell-next-input ""
"This is a temporary variable to store the intermediate results while
`accecpt-process-output' with `haskell-extract-exp'")
(defun haskell-extract-exp (str)
(setq haskell-next-input (concat haskell-next-input str))
(if (with-temp-buffer
(insert haskell-next-input)
(re-search-backward haskell-prompt-regexp nil t 1))
(progn
(push (substring haskell-next-input
0
(1- (with-temp-buffer
(insert haskell-next-input)
(re-search-backward haskell-prompt-regexp nil t 1))))
inferior-haskell-result-history)
(setq haskell-next-input ""))
""))
(defun inferior-haskell-no-result-return (strg)
(let ((proc (inferior-haskell-process)))
(with-local-quit
(progn
(add-to-list 'comint-preoutput-filter-functions
(lambda (output)
(haskell-extract-exp output)))
(process-send-string proc strg)
(accept-process-output proc)
(sit-for 0.1)
(setq comint-preoutput-filter-functions nil)))))
(defun inferior-haskell-get-result (inf-expr)
"Submit the expression `inf-expr' to ghci and read the result."
(let* ((times 5))
(inferior-haskell-no-result-return (concat inf-expr "\n"))
(while (and (> times 0)
(not (stringp (car inferior-haskell-result-history))))
(setq times (1- times))
(inferior-haskell-no-result-return (concat inf-expr "\n")))
(haskell-string-chomp (car inferior-haskell-result-history))))
(defun inferior-haskell-init ()
"The first thing run while initalizing inferior-haskell-buffer"
(with-local-quit
(with-current-buffer inferior-haskell-buffer
(process-send-string (inferior-haskell-process) "\n")
(accept-process-output (inferior-haskell-process))
(sit-for 0.1))))
(defvar haskell-set+c-p nil
"t if `:set +c` else nil")
(defun haskell-set+c ()
"set `:set +c` is not already set"
(if (not haskell-set+c-p)
(inferior-haskell-get-result ":set +c")))
(provide 'inf-haskell)
;;; inf-haskell.el ends here
