add elisp

Info.hs

@@ -10,7 +10,7 @@ import CoreUtils
 import Data.Generics as G
 import Data.List
 import Data.Maybe
-import Data.Ord
+import Data.Ord as O
 import Desugar
 import GHC
 import HscTypes
@@ -66,7 +66,7 @@ annotOf opt fileName modstr lineNo colNo = inModuleContext opt fileName modstr e
       tcm <- typecheckModule p
       es <- liftIO $ findExpr tcm lineNo colNo
       ts <- catMaybes <$> mapM (getType tcm) es
-      let ts' = sortBy (comparing $ fst) ts
+      let ts' = sortBy (\a b -> fst a `cmp` fst b) ts
       return $ tolisp $ map (\(loc, e) -> ("(" ++ l loc ++ " " ++ show (pretty e) ++ ")")) ts'
 
     l :: SrcSpan -> String
@@ -75,6 +75,11 @@ annotOf opt fileName modstr lineNo colNo = inModuleContext opt fileName modstr e
       , srcSpanEndLine spn, srcSpanEndCol spn ]
     l _ = "(0 0 0 0)"
     
+    cmp a b
+      | a `isSubspanOf` b = O.LT
+      | b `isSubspanOf` a = O.GT
+      | otherwise = O.EQ
+    
     tolisp ls = "(" ++ unwords ls ++ ")"
 
 findExpr :: TypecheckedModule -> Int -> Int -> IO [LHsExpr Id]

elisp/ghc-info.el

@@ -55,6 +55,54 @@
 	 (buffer-substring (point-min) (1- (point-max))))))
     (display-buffer buf)))
 
+(defun ghc-show-annot (&optional ask)
+  (interactive "P")
+  (if (not (ghc-which ghc-module-command))
+      (message "%s not found" ghc-module-command)
+    (let ((modname (ghc-find-module-name)))
+      (if (not modname)
+	  (message "module should be specified")
+	(ghc-show-annot0 ask modname)))))
+
+(defvar *annot-point* 0)
+(defvar *annot-ix* 0)
+(defvar *annot-ovl* (make-overlay 0 0))
+(overlay-put *annot-ovl* 'face 'region)
+
+(defun ghc-show-annot0 (ask modname)
+  (let* ((pt (point))
+         (ln (int-to-string (line-number-at-pos)))
+         (cn (int-to-string (current-column)))
+	 (cdir default-directory)
+         (buf (current-buffer))
+	 (file (buffer-name)))
+    (if (= *annot-point* pt)
+        (setq *annot-ix* (+ 1 *annot-ix*))
+      (progn
+        (setq *annot-point* pt)
+        (setq *annot-ix* 0)))
+    (save-excursion
+      (with-temp-buffer
+        (cd cdir)
+        (apply 'call-process ghc-module-command nil t nil
+               `(,@(ghc-make-ghc-options) "annot" ,file ,modname ,ln ,cn))
+        (let* ((types (read (buffer-substring (point-min) (1- (point-max)))))
+               (cix (mod *annot-ix* (length types)))
+               (tinfo (nth cix types))
+               (pos (nth 0 tinfo))
+               (type (nth 1 tinfo))
+               (left (ghc-get-pos buf (nth 0 pos) (nth 1 pos)))
+               (right (ghc-get-pos buf (nth 2 pos) (nth 3 pos))))
+          (move-overlay *annot-ovl* (- left 1) (- right 1) buf)
+          (message type))))))
+
+(defun ghc-get-pos (buf line col)
+  (save-excursion
+    (set-buffer buf)
+    (goto-line line)
+    (forward-char col)
+    (point)))
+
 (defun ghc-read-expression (default)
   (if default
       (let ((prompt (format "Expression (%s): " default)))

elisp/ghc.el

@@ -49,6 +49,7 @@
 (defvar ghc-sort-key        "\es")
 (defvar ghc-type-key        "\C-c\C-t")
 (defvar ghc-info-key        "\C-c\C-i")
+(defvar ghc-annot-key       "\C-c\C-a")
 (defvar ghc-check-key       "\C-x\C-s")
 (defvar ghc-toggle-key      "\C-c\C-c")
 (defvar ghc-module-key      "\C-c\C-m")
@@ -68,6 +69,7 @@
     (define-key haskell-mode-map ghc-document-key    'ghc-browse-document)
     (define-key haskell-mode-map ghc-type-key        'ghc-show-type)
     (define-key haskell-mode-map ghc-info-key        'ghc-show-info)
+    (define-key haskell-mode-map ghc-annot-key       'ghc-show-annot)
     (define-key haskell-mode-map ghc-import-key      'ghc-import-module)
     (define-key haskell-mode-map ghc-previous-key    'flymake-goto-prev-error)
     (define-key haskell-mode-map ghc-next-key        'flymake-goto-next-error)