From 14ef0f8372f5bbfce33ffd5eeb24659334146a12 Mon Sep 17 00:00:00 2001
From: Kazu Yamamoto <kazu@iij.ad.jp>
Date: Sun, 14 Mar 2010 22:39:45 +0900
Subject: [PATCH] M-t inserts inferred type!

---
 Check.hs             | 20 +++++++++++++-------
 elisp/ghc-flymake.el | 16 ++++++++++++++++
 elisp/ghc.el         | 26 ++++++++++++++------------
 3 files changed, 43 insertions(+), 19 deletions(-)

diff --git a/Check.hs b/Check.hs
index 875040a..5f28737 100644
--- a/Check.hs
+++ b/Check.hs
@@ -18,17 +18,23 @@ checkSyntax opt file = do
     (_,_,herr,_) <- runInteractiveProcess (ghc opt) ["--make","-Wall",file,"-outputdir","dist/flymake","-o","dist/flymake/a.out"] Nothing Nothing
     refine <$> hGetContents herr
   where
-   refine = unfoldLines start . map (dropWhile isSpace) . filter (/="") . lines
-   start = (file `isPrefixOf`)
+    refine = unfoldLines . map shrinkSpaces . remove . lines
+    remove = filter (\x -> not ("Linking" `isPrefixOf` x))
+           . filter (\x -> not ("[" `isPrefixOf` x))
+           . filter (/="")
+    shrinkSpaces x
+      | isSpace (head x) = ' ' : dropWhile isSpace x
+      | otherwise        = x
 
-unfoldLines :: (String -> Bool) -> [String] -> String
-unfoldLines _ [] = ""
-unfoldLines p (x:xs) = x ++ unfold xs
+unfoldLines :: [String] -> String
+unfoldLines [] = ""
+unfoldLines (x:xs) = x ++ unfold xs
   where
     unfold [] = "\n"
     unfold (l:ls)
-      | p l       = ('\n':l) ++ unfold ls
-      | otherwise = (' ' :l) ++ unfold ls
+      | isAlpha (head l)           = ('\n':l) ++ unfold ls
+      | " Inferred" `isPrefixOf` l = "." ++ l ++ unfold ls
+      | otherwise                  = l ++ unfold ls
 
 ----------------------------------------------------------------
 
diff --git a/elisp/ghc-flymake.el b/elisp/ghc-flymake.el
index d7ca979..e0f2168 100644
--- a/elisp/ghc-flymake.el
+++ b/elisp/ghc-flymake.el
@@ -29,4 +29,20 @@
     (list ghc-module-command (append (ghc-module-command-args)
 				     (list "check" file)))))
 
+(defun ghc-flymake-insert-type ()
+  (interactive)
+  (let ((data (ghc-flymake-data)))
+    (if (and data
+	     (string-match "Inferred type: \\([^:]+ :: \\)\\(forall [^.]+\\. \\)?\\(.*\\)" data))
+      (progn
+	(beginning-of-line)
+	(insert (match-string 1 data) (match-string 3 data) "\n"))
+      (message "No inferred type"))))
+
+(defun ghc-flymake-data ()
+  (let* ((line-no (flymake-current-line-no))
+         (line-err-info-list (nth 0 (flymake-find-err-info flymake-err-info line-no)))
+         (menu-data (flymake-make-err-menu-data line-no line-err-info-list)))
+    (nth 0 (nth 0 (nth 1 menu-data)))))
+
 (provide 'ghc-flymake)
\ No newline at end of file
diff --git a/elisp/ghc.el b/elisp/ghc.el
index 0268fb1..9b6473b 100644
--- a/elisp/ghc.el
+++ b/elisp/ghc.el
@@ -30,12 +30,13 @@
 ;;; Customize Variables
 ;;;
 
-(defvar ghc-completion-key "\e\t")
-(defvar ghc-document-key   "\e\C-d")
-(defvar ghc-import-key     "\e\C-m")
-(defvar ghc-previous-key   "\ep")
-(defvar ghc-next-key       "\en")
-(defvar ghc-help-key       "\e?")
+(defvar ghc-completion-key  "\e\t")
+(defvar ghc-document-key    "\e\C-d")
+(defvar ghc-import-key      "\e\C-m")
+(defvar ghc-previous-key    "\ep")
+(defvar ghc-next-key        "\en")
+(defvar ghc-help-key        "\e?")
+(defvar ghc-insert-type-key "\et")
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
@@ -46,12 +47,13 @@
 
 (defun ghc-init ()
   (unless ghc-initialized
-    (define-key haskell-mode-map ghc-completion-key 'ghc-complete)
-    (define-key haskell-mode-map ghc-document-key   'ghc-browse-document)
-    (define-key haskell-mode-map ghc-import-key     'ghc-load-module-buffer)
-    (define-key haskell-mode-map ghc-previous-key   'flymake-goto-prev-error)
-    (define-key haskell-mode-map ghc-next-key       'flymake-goto-next-error)
-    (define-key haskell-mode-map ghc-help-key       'flymake-display-err-menu-for-current-line)
+    (define-key haskell-mode-map ghc-completion-key  'ghc-complete)
+    (define-key haskell-mode-map ghc-document-key    'ghc-browse-document)
+    (define-key haskell-mode-map ghc-import-key      'ghc-load-module-buffer)
+    (define-key haskell-mode-map ghc-previous-key    'flymake-goto-prev-error)
+    (define-key haskell-mode-map ghc-next-key        'flymake-goto-next-error)
+    (define-key haskell-mode-map ghc-help-key        'flymake-display-err-menu-for-current-line)
+    (define-key haskell-mode-map ghc-insert-type-key 'ghc-flymake-insert-type)
     (ghc-comp-init)
     (setq ghc-initialized t)))