add annot command

This commit is contained in:
Hideyuki Tanaka 2012-02-12 21:04:18 +09:00
parent cd4a839f35
commit b8d8926ec4
3 changed files with 74 additions and 7 deletions

View File

@ -37,6 +37,7 @@ usage = "ghc-mod version " ++ showVersion version ++ "\n"
++ "\t ghc-mod check" ++ ghcOptHelp ++ "<HaskellFile>\n" ++ "\t ghc-mod check" ++ ghcOptHelp ++ "<HaskellFile>\n"
++ "\t ghc-mod type" ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n" ++ "\t ghc-mod type" ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"
++ "\t ghc-mod info" ++ 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 lint [-h opt] <HaskellFile>\n" ++ "\t ghc-mod lint [-h opt] <HaskellFile>\n"
++ "\t ghc-mod boot\n" ++ "\t ghc-mod boot\n"
++ "\t ghc-mod help\n" ++ "\t ghc-mod help\n"
@ -93,6 +94,7 @@ main = flip catches handlers $ do
"check" -> withFile (checkSyntax opt) (safelist cmdArg 1) "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) (safelist cmdArg 3)) (safelist cmdArg 1)
"info" -> withFile (infoExpr opt (safelist cmdArg 2) (safelist cmdArg 3)) (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) "lint" -> withFile (lintSyntax opt) (safelist cmdArg 1)
"lang" -> listLanguages opt "lang" -> listLanguages opt
"flag" -> listFlags opt "flag" -> listFlags opt

75
Info.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP, Rank2Types, TupleSections #-}
module Info where module Info where
@ -6,8 +6,12 @@ import Cabal
import Control.Applicative hiding (empty) import Control.Applicative hiding (empty)
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
import CoreUtils
import Data.Generics as G
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.Ord
import Desugar
import GHC import GHC
import HscTypes import HscTypes
import NameSet import NameSet
@ -15,6 +19,7 @@ import Outputable
import PprTyThing import PprTyThing
import StringBuffer import StringBuffer
import System.Time import System.Time
import TcRnTypes
import Types import Types
#if __GLASGOW_HASKELL__ >= 702 #if __GLASGOW_HASKELL__ >= 702
@ -27,12 +32,14 @@ type ModuleString = String
---------------------------------------------------------------- ----------------------------------------------------------------
typeExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String typeExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String
typeExpr opt modstr expr file = (++ "\n") <$> typeOf opt file modstr expr typeExpr opt modstr expr file = (++ "\n") <$> Info.typeOf opt file modstr expr
typeOf :: Options -> FilePath -> ModuleString -> Expression -> IO String typeOf :: Options -> FilePath -> ModuleString -> Expression -> IO String
typeOf opt fileName modstr expr = inModuleContext opt fileName modstr exprToType typeOf opt fileName modstr expr = inModuleContext opt fileName modstr exprToType
where where
exprToType = pretty <$> exprType expr exprToType = pretty <$> GHC.exprType expr
pretty :: Type -> String
pretty = showSDocForUser neverQualify . pprTypeForUser False pretty = showSDocForUser neverQualify . pprTypeForUser False
---------------------------------------------------------------- ----------------------------------------------------------------
@ -45,6 +52,64 @@ info opt fileName modstr expr = inModuleContext opt fileName modstr exprToInfo
where where
exprToInfo = infoThing expr exprToInfo = infoThing expr
----------------------------------------------------------------
annotExpr :: Options -> ModuleString -> Int -> Int -> FilePath -> IO String
annotExpr opt modstr lineNo colNo file = (++ "\n") <$> annotOf opt file modstr lineNo colNo
annotOf :: Options -> FilePath -> ModuleString -> Int -> Int -> IO String
annotOf opt fileName modstr lineNo colNo = inModuleContext opt fileName modstr exprToType
where
exprToType = do
modSum <- getModSummary $ mkModuleName modstr
p <- parseModule modSum
tcm <- typecheckModule p
es <- liftIO $ findExpr tcm lineNo colNo
ts <- catMaybes <$> mapM (getType tcm) es
let ts' = sortBy (comparing $ fst) ts
return $ tolisp $ map (\(loc, e) -> ("(" ++ l loc ++ " " ++ show (pretty e) ++ ")")) ts'
l :: SrcSpan -> String
l (RealSrcSpan spn) = ("("++) . (++")") . unwords . map show $
[ srcSpanStartLine spn, srcSpanStartCol spn
, srcSpanEndLine spn, srcSpanEndCol spn ]
l _ = "(0 0 0 0)"
tolisp ls = "(" ++ unwords ls ++ ")"
findExpr :: TypecheckedModule -> Int -> Int -> IO [LHsExpr Id]
findExpr tcm line col = do
let src = tm_typechecked_source tcm
ssrc <- everywhereM' sanitize src
return $ listify f ssrc
where
-- It is for GHC's panic!
sanitize :: Data a => a -> IO a
sanitize x = do
mret <- try (evaluate x)
return $ case mret of
Left (SomeException _) -> G.empty
Right ret -> ret
f :: LHsExpr Id -> Bool
f (L spn _) = spn `spans` (line, col)
-- | Monadic variation on everywhere'
everywhereM' :: Monad m => GenericM m -> GenericM m
everywhereM' f x = do
x' <- f x
gmapM (everywhereM' f) x'
getType :: GhcMonad m => TypecheckedModule -> LHsExpr Id -> m (Maybe (SrcSpan, Type))
getType tcm e = do
hs_env <- getSession
(_, mbe) <- liftIO $ deSugarExpr hs_env modu rn_env ty_env e
return $ (getLoc e, ) <$> CoreUtils.exprType <$> mbe
where
modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm
rn_env = tcg_rdr_env $ fst $ tm_internals_ tcm
ty_env = tcg_type_env $ fst $ tm_internals_ tcm
---------------------------------------------------------------- ----------------------------------------------------------------
-- from ghc/InteractiveUI.hs -- from ghc/InteractiveUI.hs
@ -62,14 +127,14 @@ filterOutChildren get_thing xs
where where
implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [Instance]) -> SDoc pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [Instance]) -> SDoc
pprInfo pefas (thing, fixity, insts) pprInfo pefas (thing, fixity, insts)
= pprTyThingInContextLoc pefas thing = pprTyThingInContextLoc pefas thing
$$ show_fixity fixity $$ show_fixity fixity
$$ vcat (map pprInstance insts) $$ vcat (map pprInstance insts)
where where
show_fixity fix show_fixity fix
| fix == defaultFixity = empty | fix == defaultFixity = Outputable.empty
| otherwise = ppr fix <+> ppr (getName thing) | otherwise = ppr fix <+> ppr (getName thing)
---------------------------------------------------------------- ----------------------------------------------------------------

View File

@ -28,7 +28,7 @@ Executable ghc-mod
GHC-Options: -Wall -fno-warn-unused-do-bind GHC-Options: -Wall -fno-warn-unused-do-bind
else else
GHC-Options: -Wall GHC-Options: -Wall
Build-Depends: base >= 4.0 && < 5, ghc, ghc-paths, transformers, Build-Depends: base >= 4.0 && < 5, ghc, ghc-paths, transformers, syb,
process, directory, filepath, old-time, process, directory, filepath, old-time,
hlint >= 1.7.1, regex-posix, Cabal hlint >= 1.7.1, regex-posix, Cabal
Source-Repository head Source-Repository head