;;; inf-haskell.el --- Interaction with an inferior Haskell process.

;; Copyright (C) 2004, 2005  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)

;; 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-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]\\):\\( \\|$\\)" 1 3)
    )
  "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-dirtrackp) t)
  (set (make-local-variable 'shell-cd-regexp) ":cd")
  (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: "))))

(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
(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)
      (if (boundp 'compilation-parsing-end)
	  (if (markerp compilation-parsing-end)
	      (set-marker compilation-parsing-end (point-max))
	    (setq compilation-parsing-end (point-max))))
      (inferior-haskell-send-command
       proc (if reload ":reload" (concat ":load \"" file "\""))))))

(defun inferior-haskell-send-command (proc str)
  (setq str (concat str "\n"))
  (with-current-buffer (process-buffer proc)
    (while (and
	    (goto-char comint-last-input-end)
	    (not (re-search-forward comint-prompt-regexp nil t))
	    (accept-process-output 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))

(provide 'inf-haskell)

;;; inf-haskell.el ends here
