hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

avoid GHC's panic

Browse Source
This commit is contained in:
eagletmt 2012-02-14 03:20:33 +09:00
parent 1e1b729e15
commit 122167f4c1
2 changed files with 12 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
Info.hs
View File

@ -8,7 +8,8 @@ import Control.Exception
import Control.Monad import Control.Monad
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
@ -52,7 +53,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 <- 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
@ -75,28 +76,18 @@ 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)
| otherwise = False
-- | 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

2
ghc-mod.cabal
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, syb, Build-Depends: base >= 4.0 && < 5, ghc, ghc-paths, transformers, syb, ghc-syb-utils,
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