(inferior-haskell-info-xref-re): New cst.

Ignore-this: ce4a5e92609010c1a9935bad0aee6468
(inferior-haskell-info-xref-re): New cst.
(inferior-haskell-error-regexp-alist): Use it to highlight xref info.
(inferior-haskell-type, inferior-haskell-info)
(inferior-haskell-find-definition): New funs.
Contributed by Matthew Danish <mrd@cs.cmu.edu>.

darcs-hash:20070210072307-c2f2e-1e9b01952d8907831e475c9f665f9446ae359871.gz

inf-haskell.el

@@ -1,6 +1,6 @@
 ;;; inf-haskell.el --- Interaction with an inferior Haskell process.
 
-;; Copyright (C) 2004, 2005, 2006  Free Software Foundation, Inc.
+;; Copyright (C) 2004, 2005, 2006, 2007  Free Software Foundation, Inc.
 
 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
 ;; Keywords: Haskell
@@ -30,6 +30,7 @@
 (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.
@@ -49,12 +50,19 @@ The command can include arguments."
   :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)))))
+     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'.")
 
@@ -209,6 +217,110 @@ The process PROC should be associated to a comint buffer."
   (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