defining "info" for "ESC i".

This commit is contained in:
Kazu Yamamoto 2010-11-15 14:46:59 +09:00
parent fc67daae89
commit 11f1341fe5
4 changed files with 83 additions and 10 deletions

View File

@ -28,6 +28,7 @@ usage = "ghc-mod version 0.5.0\n"
++ "\t ghc-mod [-l] browse <module> [<module> ...]\n"
++ "\t ghc-mod check <HaskellFile>\n"
++ "\t ghc-mod type <HaskellFile> <expression>\n"
++ "\t ghc-mod info <HaskellFile> <expression>\n"
++ "\t ghc-mod [-h opt] lint <HaskellFile>\n"
++ "\t ghc-mod boot\n"
++ "\t ghc-mod help\n"
@ -75,6 +76,7 @@ main = flip catches handlers $ do
"list" -> listModules opt
"check" -> withFile (checkSyntax opt) (safelist cmdArg 1)
"type" -> withFile (typeExpr opt (safelist cmdArg 2)) (safelist cmdArg 1)
"info" -> withFile (infoExpr opt (safelist cmdArg 2)) (safelist cmdArg 1)
"lint" -> withFile (lintSyntax opt) (safelist cmdArg 1)
"lang" -> listLanguages opt
"boot" -> do

52
Info.hs
View File

@ -1,10 +1,16 @@
module Info where
import Control.Applicative
import Control.Applicative hiding (empty)
import Data.Maybe
import GHC
import Outputable
import PprTyThing
import Types
import NameSet
import HscTypes
import Data.List
----------------------------------------------------------------
typeExpr :: Options -> String -> String -> IO String
typeExpr _ expr file = (++ "\n") <$> typeOf file expr
@ -17,8 +23,50 @@ typeOf fileName expr = withGHC $ do
setContextFromTarget
pretty <$> exprType expr
where
pretty = showSDocForUser neverQualify . pprTypeForUser False
----------------------------------------------------------------
infoExpr :: Options -> String -> String -> IO String
infoExpr _ expr file = (++ "\n") <$> info file expr
info :: String -> String -> IO String
info fileName expr = withGHC $ do
initSession []
setTargetFile fileName
load LoadAllTargets
setContextFromTarget
infoThing expr
where
-- ghc/InteractiveUI.hs
infoThing str = do
names <- parseName str
mb_stuffs <- mapM getInfo names
let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
unqual <- getPrintUnqual
return $ showSDocForUser unqual $ vcat (intersperse (text "") $ map (pprInfo False) filtered)
-- ghc/InteractiveUI.hs
filterOutChildren :: (a -> TyThing) -> [a] -> [a]
filterOutChildren get_thing xs
= [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
where
implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
pprInfo pefas (thing, fixity, insts)
= pprTyThingInContextLoc pefas thing
$$ show_fixity fixity
$$ vcat (map pprInstance insts)
where
show_fixity fix
| fix == defaultFixity = empty
| otherwise = ppr fix <+> ppr (getName thing)
----------------------------------------------------------------
setContextFromTarget :: Ghc ()
setContextFromTarget = do
ms <- depanal [] False
mdl <- findModule (ms_mod_name (head ms)) Nothing
setContext [mdl] []
pretty = showSDocForUser neverQualify . pprTypeForUser False

View File

@ -10,14 +10,35 @@
(require 'ghc-func)
(defun ghc-show-type ()
(interactive)
(defun ghc-show-type (&optional ask)
(interactive "P")
(if (not (ghc-which ghc-module-command))
(message "%s not found" ghc-module-command)
(let ((expr (thing-at-point 'symbol))
(let* ((expr0 (thing-at-point 'symbol))
(expr (if ask (ghc-read-expression expr0) expr0))
(file (buffer-name)))
(with-temp-buffer
(call-process ghc-module-command nil t nil "type" file expr)
(message (buffer-substring (point-min) (1- (point-max))))))))
(defun ghc-show-info (&optional ask)
(interactive "P")
(if (not (ghc-which ghc-module-command))
(message "%s not found" ghc-module-command)
(let* ((expr0 (thing-at-point 'symbol))
(expr (if ask (ghc-read-expression expr0) expr0))
(file (buffer-name))
(buf (get-buffer-create ghc-error-buffer-name)))
(with-current-buffer buf
(erase-buffer)
(insert
(with-temp-buffer
(call-process ghc-module-command nil t nil "info" file expr)
(buffer-substring (point-min) (1- (point-max))))))
(display-buffer buf))))
(defun ghc-read-expression (default)
(let ((prompt (format "Expression (%s): " default)))
(read-string prompt default nil)))
(provide 'ghc-info)

View File

@ -41,7 +41,8 @@
(defvar ghc-help-key "\e?")
(defvar ghc-insert-key "\et")
(defvar ghc-sort-key "\es")
(defvar ghc-type-key "\e\C-t")
(defvar ghc-type-key "\ek")
(defvar ghc-info-key "\ei")
(defvar ghc-check-key "\C-x\C-s")
(defvar ghc-toggle-key "\C-c\C-c")
@ -58,6 +59,7 @@
(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-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)