From b8d8926ec449ef568fcd8f428ef4a835ab585490 Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Sun, 12 Feb 2012 21:04:18 +0900 Subject: [PATCH] add annot command --- GHCMod.hs | 2 ++ Info.hs | 77 +++++++++++++++++++++++++++++++++++++++++++++++---- ghc-mod.cabal | 2 +- 3 files changed, 74 insertions(+), 7 deletions(-) diff --git a/GHCMod.hs b/GHCMod.hs index 14061f8..e134720 100644 --- a/GHCMod.hs +++ b/GHCMod.hs @@ -37,6 +37,7 @@ usage = "ghc-mod version " ++ showVersion version ++ "\n" ++ "\t ghc-mod check" ++ ghcOptHelp ++ "\n" ++ "\t ghc-mod type" ++ ghcOptHelp ++ " \n" ++ "\t ghc-mod info" ++ ghcOptHelp ++ " \n" + ++ "\t ghc-mod annot" ++ ghcOptHelp ++ " \n" ++ "\t ghc-mod lint [-h opt] \n" ++ "\t ghc-mod boot\n" ++ "\t ghc-mod help\n" @@ -93,6 +94,7 @@ main = flip catches handlers $ do "check" -> withFile (checkSyntax opt) (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) + "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 diff --git a/Info.hs b/Info.hs index dd9f550..a620cd9 100644 --- a/Info.hs +++ b/Info.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, Rank2Types, TupleSections #-} module Info where @@ -6,8 +6,12 @@ import Cabal import Control.Applicative hiding (empty) import Control.Exception import Control.Monad +import CoreUtils +import Data.Generics as G import Data.List import Data.Maybe +import Data.Ord +import Desugar import GHC import HscTypes import NameSet @@ -15,6 +19,7 @@ import Outputable import PprTyThing import StringBuffer import System.Time +import TcRnTypes import Types #if __GLASGOW_HASKELL__ >= 702 @@ -27,13 +32,15 @@ type ModuleString = 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 opt fileName modstr expr = inModuleContext opt fileName modstr exprToType where - exprToType = pretty <$> exprType expr - pretty = showSDocForUser neverQualify . pprTypeForUser False + exprToType = pretty <$> GHC.exprType expr + +pretty :: Type -> String +pretty = showSDocForUser neverQualify . pprTypeForUser False ---------------------------------------------------------------- @@ -45,6 +52,64 @@ info opt fileName modstr expr = inModuleContext opt fileName modstr exprToInfo where 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 @@ -62,14 +127,14 @@ filterOutChildren get_thing xs where 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) = pprTyThingInContextLoc pefas thing $$ show_fixity fixity $$ vcat (map pprInstance insts) where show_fixity fix - | fix == defaultFixity = empty + | fix == defaultFixity = Outputable.empty | otherwise = ppr fix <+> ppr (getName thing) ---------------------------------------------------------------- diff --git a/ghc-mod.cabal b/ghc-mod.cabal index a4f4345..3c64d3e 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -28,7 +28,7 @@ Executable ghc-mod GHC-Options: -Wall -fno-warn-unused-do-bind else 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, hlint >= 1.7.1, regex-posix, Cabal Source-Repository head