;;; 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