annot -> type.

GHCMod.hs

@@ -35,9 +35,8 @@ usage =    "ghc-mod version " ++ showVersion version ++ "\n"
         ++ "\t ghc-mod flag [-l]\n"
         ++ "\t ghc-mod browse" ++ ghcOptHelp ++ "[-l] [-o] <module> [<module> ...]\n"
         ++ "\t ghc-mod check" ++ ghcOptHelp ++ "<HaskellFile>\n"
-        ++ "\t ghc-mod type" ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"
         ++ "\t ghc-mod info" ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"
-        ++ "\t ghc-mod annot" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
+        ++ "\t ghc-mod type" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
         ++ "\t ghc-mod lint [-h opt] <HaskellFile>\n"
         ++ "\t ghc-mod boot\n"
         ++ "\t ghc-mod help\n"
@@ -92,9 +91,8 @@ main = flip catches handlers $ do
       "browse" -> concat <$> mapM (browseModule opt) (tail cmdArg)
       "list"   -> listModules opt
       "check"  -> withFile (checkSyntax opt) (safelist cmdArg 1)
-      "type"   -> withFile (typeExpr opt (safelist cmdArg 2) (safelist cmdArg 3)) (safelist cmdArg 1)
+      "type"  -> withFile (typeExpr opt (safelist cmdArg 2) (read $ safelist cmdArg 3) (read $ safelist cmdArg 4)) (safelist cmdArg 1)
       "info"   -> withFile (infoExpr opt (safelist cmdArg 2) (safelist cmdArg 3)) (safelist cmdArg 1)
-      "annot"  -> withFile (annotExpr opt (safelist cmdArg 2) (read $ safelist cmdArg 3) (read $ safelist cmdArg 4)) (safelist cmdArg 1)
       "lint"   -> withFile (lintSyntax opt)  (safelist cmdArg 1)
       "lang"   -> listLanguages opt
       "flag"   -> listFlags opt

Info.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE CPP, Rank2Types, TupleSections #-}
 
-module Info where
+module Info (infoExpr, typeExpr) where
 
 import Cabal
 import Control.Applicative hiding (empty)
@@ -31,19 +31,6 @@ type ModuleString = String
 
 ----------------------------------------------------------------
 
-typeExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String
-typeExpr opt modstr expr file = (++ "\n") <$> Info.typeOf opt file modstr expr
-
-typeOf :: Options -> FilePath -> ModuleString -> Expression -> IO String
-typeOf opt fileName modstr expr = inModuleContext opt fileName modstr exprToType
-  where
-    exprToType = pretty <$> GHC.exprType expr
-
-pretty :: Type -> String
-pretty = showSDocForUser neverQualify . pprTypeForUser False
-
-----------------------------------------------------------------
-
 infoExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String
 infoExpr opt modstr expr file = (++ "\n") <$> info opt file modstr expr
 
@@ -54,11 +41,11 @@ info opt fileName modstr expr = inModuleContext opt fileName modstr exprToInfo
 
 ----------------------------------------------------------------
 
-annotExpr :: Options -> ModuleString -> Int -> Int -> FilePath -> IO String
+typeExpr :: Options -> ModuleString -> Int -> Int -> FilePath -> IO String
-annotExpr opt modstr lineNo colNo file = (++ "\n") <$> annotOf opt file modstr lineNo colNo
+typeExpr opt modstr lineNo colNo file = (++ "\n") <$> Info.typeOf opt file modstr lineNo colNo
 
-annotOf :: Options -> FilePath -> ModuleString -> Int -> Int -> IO String
+typeOf :: Options -> FilePath -> ModuleString -> Int -> Int -> IO String
-annotOf opt fileName modstr lineNo colNo = inModuleContext opt fileName modstr exprToType
+typeOf opt fileName modstr lineNo colNo = inModuleContext opt fileName modstr exprToType
   where
     exprToType = do
       modSum <- getModSummary $ mkModuleName modstr
@@ -120,6 +107,9 @@ getType tcm e = do
     rn_env = tcg_rdr_env $ fst $ tm_internals_ tcm
     ty_env = tcg_type_env $ fst $ tm_internals_ tcm
 
+pretty :: Type -> String
+pretty = showSDocForUser neverQualify . pprTypeForUser False
+
 ----------------------------------------------------------------
 -- from ghc/InteractiveUI.hs
 

elisp/ghc-info.el

@@ -10,26 +10,6 @@
 
 (require 'ghc-func)
 
-(defun ghc-show-type (&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-type0 ask modname)))))
-
-(defun ghc-show-type0 (ask modname)
-  (let* ((expr0 (ghc-things-at-point))
-	 (expr (if ask (ghc-read-expression expr0) expr0))
-	 (cdir default-directory)
-	 (file (buffer-name)))
-    (with-temp-buffer
-      (cd cdir)
-      (apply 'call-process ghc-module-command nil t nil
-	     `(,@(ghc-make-ghc-options) "type" ,file ,modname ,expr))
-      (message (buffer-substring (point-min) (1- (point-max)))))))
-
 (defun ghc-show-info (&optional ask)
   (interactive "P")
   (if (not (ghc-which ghc-module-command))
@@ -57,73 +37,73 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
-;;; annot
+;;; type
 ;;;
 
-(defvar ghc-annot-overlay nil)
+(defvar ghc-type-overlay nil)
 
-(make-variable-buffer-local 'ghc-annot-overlay)
+(make-variable-buffer-local 'ghc-type-overlay)
 
-(defun ghc-annot-set-ix (n)
+(defun ghc-type-set-ix (n)
-  (overlay-put ghc-annot-overlay 'ix n))
+  (overlay-put ghc-type-overlay 'ix n))
 
-(defun ghc-annot-get-ix ()
+(defun ghc-type-get-ix ()
-  (overlay-get ghc-annot-overlay 'ix))
+  (overlay-get ghc-type-overlay 'ix))
 
-(defun ghc-annot-set-point (pos)
+(defun ghc-type-set-point (pos)
-  (overlay-put ghc-annot-overlay 'pos pos))
+  (overlay-put ghc-type-overlay 'pos pos))
 
-(defun ghc-annot-get-point ()
+(defun ghc-type-get-point ()
-  (overlay-get ghc-annot-overlay 'pos))
+  (overlay-get ghc-type-overlay 'pos))
 
-(defun ghc-annot-set-types (types)
+(defun ghc-type-set-types (types)
-  (overlay-put ghc-annot-overlay 'types types))
+  (overlay-put ghc-type-overlay 'types types))
 
-(defun ghc-annot-get-types ()
+(defun ghc-type-get-types ()
-  (overlay-get ghc-annot-overlay 'types))
+  (overlay-get ghc-type-overlay 'types))
 
-(defun ghc-annot-init ()
+(defun ghc-type-init ()
-  (setq ghc-annot-overlay (make-overlay 0 0))
+  (setq ghc-type-overlay (make-overlay 0 0))
-  (overlay-put ghc-annot-overlay 'face 'region)
+  (overlay-put ghc-type-overlay 'face 'region)
-  (ghc-annot-set-ix 0)
+  (ghc-type-set-ix 0)
-  (ghc-annot-set-point 0)
+  (ghc-type-set-point 0)
   (setq after-change-functions
-	(cons 'ghc-delete-annot-ovl after-change-functions)))
+	(cons 'ghc-delete-type-ovl after-change-functions)))
 
-(defun ghc-delete-annot-ovl (beg end len)
+(defun ghc-delete-type-ovl (beg end len)
-  (when (overlayp ghc-annot-overlay)
+  (when (overlayp ghc-type-overlay)
-    (delete-overlay ghc-annot-overlay)))
+    (delete-overlay ghc-type-overlay)))
 
-(defun ghc-show-annot ()
+(defun ghc-show-type ()
   (interactive)
   (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 modname)))))
+	(ghc-show-type0 modname)))))
 
-(defun ghc-show-annot0 (modname)
+(defun ghc-show-type0 (modname)
   (let* ((buf (current-buffer))
-	 (types (ghc-get-annot modname))
+	 (types (ghc-get-type modname))
-	 (tinfo (nth (ghc-annot-get-ix) types))
+	 (tinfo (nth (ghc-type-get-ix) 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 ghc-annot-overlay (- left 1) (- right 1) buf)
+      (move-overlay ghc-type-overlay (- left 1) (- right 1) buf)
       (message type)))
 
-(defun ghc-get-annot (modname)
+(defun ghc-get-type (modname)
-  (if (= (ghc-annot-get-point) (point))
+  (if (= (ghc-type-get-point) (point))
-      (ghc-annot-set-ix
+      (ghc-type-set-ix
-       (mod (1+ (ghc-annot-get-ix)) (length (ghc-annot-get-types))))
+       (mod (1+ (ghc-type-get-ix)) (length (ghc-type-get-types))))
-    (ghc-annot-set-types (ghc-call-annot modname))
+    (ghc-type-set-types (ghc-call-type modname))
-    (ghc-annot-set-point (point))
+    (ghc-type-set-point (point))
-    (ghc-annot-set-ix 0))
+    (ghc-type-set-ix 0))
-  (ghc-annot-get-types))
+  (ghc-type-get-types))
 
-(defun ghc-call-annot (modname)
+(defun ghc-call-type (modname)
   (let* ((ln (int-to-string (line-number-at-pos)))
 	 (cn (int-to-string (current-column)))
 	 (cdir default-directory)
@@ -132,7 +112,7 @@
      (lambda ()
        (cd cdir)
        (apply 'call-process ghc-module-command nil t nil
-	      `(,@(ghc-make-ghc-options) "annot" ,file ,modname ,ln ,cn))))))
+	      `(,@(ghc-make-ghc-options) "type" ,file ,modname ,ln ,cn))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;

elisp/ghc.el

@@ -49,7 +49,6 @@
 (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")
@@ -64,13 +63,12 @@
 
 (defun ghc-init ()
   (ghc-abbrev-init)
-  (ghc-annot-init)
+  (ghc-type-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-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)