Merge remote-tracking branch 'eagletmt/ghc-syb-utils'

This commit is contained in:
Kazu Yamamoto 2012-02-14 16:16:26 +09:00
commit 416c901188
2 changed files with 10 additions and 21 deletions

30
Info.hs
View File

@ -4,10 +4,10 @@ module Info (infoExpr, typeExpr) where
import Cabal import Cabal
import Control.Applicative import Control.Applicative
import Control.Exception
import CoreUtils import CoreUtils
import Data.Function import Data.Function
import Data.Generics as G import Data.Generics
import GHC.SYB.Utils
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.Ord as O import Data.Ord as O
@ -50,7 +50,7 @@ typeOf opt fileName modstr lineNo colNo = inModuleContext opt fileName modstr ex
modSum <- getModSummary $ mkModuleName modstr modSum <- getModSummary $ mkModuleName modstr
p <- parseModule modSum p <- parseModule modSum
tcm <- typecheckModule p tcm <- typecheckModule p
es <- Gap.liftIO $ findExpr tcm lineNo colNo let es = findExpr tcm lineNo colNo
ts <- catMaybes <$> mapM (getType tcm) es ts <- catMaybes <$> mapM (getType tcm) es
let sss = map toTup $ sortBy (cmp `on` fst) ts let sss = map toTup $ sortBy (cmp `on` fst) ts
return $ convert opt sss return $ convert opt sss
@ -66,28 +66,16 @@ typeOf opt fileName modstr lineNo colNo = inModuleContext opt fileName modstr ex
| b `isSubspanOf` a = O.GT | b `isSubspanOf` a = O.GT
| otherwise = O.EQ | otherwise = O.EQ
findExpr :: TypecheckedModule -> Int -> Int -> IO [LHsExpr Id] findExpr :: TypecheckedModule -> Int -> Int -> [LHsExpr Id]
findExpr tcm line col = do findExpr tcm line col =
let src = tm_typechecked_source tcm let src = tm_typechecked_source tcm
ssrc <- everywhereM' sanitize src in listifyStaged TypeChecker f src
return $ listify f ssrc
where 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 :: LHsExpr Id -> Bool
f (L spn _) = spn `spans` (line, col) f (L spn _) = isGoodSrcSpan spn && spn `spans` (line, col)
-- | Monadic variation on everywhere' listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]
everywhereM' :: Monad m => GenericM m -> GenericM m listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> if p x then [x] else []))
everywhereM' f x = do
x' <- f x
gmapM (everywhereM' f) x'
getType :: GhcMonad m => TypecheckedModule -> LHsExpr Id -> m (Maybe (SrcSpan, Type)) getType :: GhcMonad m => TypecheckedModule -> LHsExpr Id -> m (Maybe (SrcSpan, Type))
getType tcm e = do getType tcm e = do

View File

@ -47,6 +47,7 @@ Executable ghc-mod
, filepath , filepath
, ghc , ghc
, ghc-paths , ghc-paths
, ghc-syb-utils
, hlint >= 1.7.1 , hlint >= 1.7.1
, old-time , old-time
, process , process