removing target file set from ghc-modi.

This prevents errors if a package has multiple targets and test suites.
But this is still fast enough.
This commit is contained in:
Kazu Yamamoto 2014-09-18 12:17:59 +09:00
parent 357694c6cc
commit e66aefebee

View File

@ -25,14 +25,10 @@ import Control.Exception (SomeException(..), Exception)
import qualified Control.Exception as E
import Control.Monad (when)
import CoreMonad (liftIO)
import Data.List (find, intercalate)
import Data.List (intercalate)
import Data.List.Split (splitOn)
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Typeable (Typeable)
import Data.Version (showVersion)
import qualified GHC as G
import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal
import Paths_ghc_mod
@ -102,7 +98,7 @@ main = E.handle cmdHandler $
-- c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????
setCurrentDirectory rootdir
symDb <- async $ runGhcModT opt loadSymbolDb
(res, _) <- runGhcModT opt $ loop S.empty symDb
(res, _) <- runGhcModT opt $ loop symDb
case res of
Right () -> return ()
@ -132,91 +128,58 @@ replace needle replacement = intercalate replacement . splitOn needle
----------------------------------------------------------------
loop :: IOish m => Set FilePath -> SymDbReq -> GhcModT m ()
loop set symDbReq = do
loop :: IOish m => SymDbReq -> GhcModT m ()
loop symDbReq = do
cmdArg <- liftIO getLine
let (cmd,arg') = break (== ' ') cmdArg
arg = dropWhile (== ' ') arg'
(ret,ok,set') <- case cmd of
"check" -> checkStx set arg
"find" -> findSym set arg symDbReq
"lint" -> lintStx set arg
"info" -> showInfo set arg
"type" -> showType set arg
"split" -> doSplit set arg
"sig" -> doSig set arg
"refine" -> doRefine set arg
"auto" -> doAuto set arg
"boot" -> bootIt set
"browse" -> browseIt set arg
"quit" -> return ("quit", False, set)
"" -> return ("quit", False, set)
_ -> return ([], True, set)
(ret,ok) <- case cmd of
"check" -> checkStx arg
"find" -> findSym arg symDbReq
"lint" -> lintStx arg
"info" -> showInfo arg
"type" -> showType arg
"split" -> doSplit arg
"sig" -> doSig arg
"refine" -> doRefine arg
"auto" -> doAuto arg
"boot" -> bootIt
"browse" -> browseIt arg
"quit" -> return ("quit", False)
"" -> return ("quit", False)
_ -> return ([], True)
if ok then do
liftIO $ putStr ret
liftIO $ putStrLn "OK"
else do
liftIO $ putStrLn $ notGood ret
liftIO $ hFlush stdout
when ok $ loop set' symDbReq
when ok $ loop symDbReq
----------------------------------------------------------------
checkStx :: IOish m
=> Set FilePath
-> FilePath
-> GhcModT m (String, Bool, Set FilePath)
checkStx set file = do
set' <- newFileSet set file
let files = S.toList set'
eret <- check files
checkStx :: IOish m => FilePath -> GhcModT m (String, Bool)
checkStx file = do
eret <- check [file]
case eret of
Right ret -> return (ret, True, set')
Left ret -> return (ret, True, set) -- fxime: set
newFileSet :: IOish m => Set FilePath -> FilePath -> GhcModT m (Set FilePath)
newFileSet set file = do
let set1
| S.member file set = set
| otherwise = S.insert file set
mx <- isSameMainFile file <$> getModSummaryForMain
return $ case mx of
Nothing -> set1
Just mainfile -> S.delete mainfile set1
getModSummaryForMain :: IOish m => GhcModT m (Maybe G.ModSummary)
getModSummaryForMain = find isMain <$> G.getModuleGraph
where
isMain m = G.moduleNameString (G.moduleName (G.ms_mod m)) == "Main"
isSameMainFile :: FilePath -> (Maybe G.ModSummary) -> Maybe FilePath
isSameMainFile _ Nothing = Nothing
isSameMainFile file (Just x)
| mainfile == file = Nothing
| otherwise = Just mainfile
where
mmainfile = G.ml_hs_file (G.ms_location x)
-- G.ms_hspp_file x is a temporary file with CPP.
-- this is a just fake.
mainfile = fromMaybe (G.ms_hspp_file x) mmainfile
Right ret -> return (ret, True)
Left ret -> return (ret, True)
----------------------------------------------------------------
type SymDbReq = Async (Either GhcModError SymbolDb, GhcModLog)
findSym :: IOish m => Set FilePath -> String -> SymDbReq
-> GhcModT m (String, Bool, Set FilePath)
findSym set sym dbReq = do
findSym :: IOish m => String -> SymDbReq
-> GhcModT m (String, Bool)
findSym sym dbReq = do
db <- hoistGhcModT =<< liftIO (wait dbReq)
ret <- lookupSymbol sym db
return (ret, True, set)
return (ret, True)
lintStx :: IOish m => Set FilePath
-> FilePath
-> GhcModT m (String, Bool, Set FilePath)
lintStx set optFile = do
lintStx :: IOish m => FilePath -> GhcModT m (String, Bool)
lintStx optFile = do
ret <- withOptions changeOpt $ lint file
return (ret, True, set)
return (ret, True)
where
(opts,file) = parseLintOptions optFile
hopts = if opts == "" then [] else read opts
@ -239,85 +202,56 @@ parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of
----------------------------------------------------------------
showInfo :: IOish m
=> Set FilePath
-> FilePath
-> GhcModT m (String, Bool, Set FilePath)
showInfo set fileArg = do
showInfo :: IOish m => FilePath -> GhcModT m (String, Bool)
showInfo fileArg = do
let [file, expr] = splitN 2 fileArg
set' <- newFileSet set file
ret <- info file expr
return (ret, True, set')
return (ret, True)
showType :: IOish m
=> Set FilePath
-> FilePath
-> GhcModT m (String, Bool, Set FilePath)
showType set fileArg = do
showType :: IOish m => FilePath -> GhcModT m (String, Bool)
showType fileArg = do
let [file, line, column] = splitN 3 fileArg
set' <- newFileSet set file
ret <- types file (read line) (read column)
return (ret, True, set')
return (ret, True)
doSplit :: IOish m
=> Set FilePath
-> FilePath
-> GhcModT m (String, Bool, Set FilePath)
doSplit set fileArg = do
doSplit :: IOish m => FilePath -> GhcModT m (String, Bool)
doSplit fileArg = do
let [file, line, column] = splitN 3 fileArg
set' <- newFileSet set file
ret <- splits file (read line) (read column)
return (ret, True, set')
return (ret, True)
doSig :: IOish m
=> Set FilePath
-> FilePath
-> GhcModT m (String, Bool, Set FilePath)
doSig set fileArg = do
doSig :: IOish m => FilePath -> GhcModT m (String, Bool)
doSig fileArg = do
let [file, line, column] = splitN 3 fileArg
set' <- newFileSet set file
ret <- sig file (read line) (read column)
return (ret, True, set')
return (ret, True)
doRefine :: IOish m
=> Set FilePath
-> FilePath
-> GhcModT m (String, Bool, Set FilePath)
doRefine set fileArg = do
doRefine :: IOish m => FilePath -> GhcModT m (String, Bool)
doRefine fileArg = do
let [file, line, column, expr] = splitN 4 fileArg
set' <- newFileSet set file
ret <- refine file (read line) (read column) expr
return (ret, True, set')
return (ret, True)
doAuto :: IOish m
=> Set FilePath
-> FilePath
-> GhcModT m (String, Bool, Set FilePath)
doAuto set fileArg = do
doAuto :: IOish m => FilePath -> GhcModT m (String, Bool)
doAuto fileArg = do
let [file, line, column] = splitN 3 fileArg
set' <- newFileSet set file
ret <- auto file (read line) (read column)
return (ret, True, set')
return (ret, True)
----------------------------------------------------------------
bootIt :: IOish m
=> Set FilePath
-> GhcModT m (String, Bool, Set FilePath)
bootIt set = do
bootIt :: IOish m => GhcModT m (String, Bool)
bootIt = do
ret <- boot
return (ret, True, set)
return (ret, True)
browseIt :: IOish m
=> Set FilePath
-> ModuleString
-> GhcModT m (String, Bool, Set FilePath)
browseIt set mdl = do
browseIt :: IOish m => ModuleString -> GhcModT m (String, Bool)
browseIt mdl = do
let (det,rest') = break (== ' ') mdl
rest = dropWhile (== ' ') rest'
ret <- if det == "-d"
then withOptions setDetailed (browse rest)
else browse mdl
return (ret, True, set)
return (ret, True)
where
setDetailed opt = opt { detailed = True }