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
parent
357694c6cc
commit
e66aefebee
178
src/GHCModi.hs
178
src/GHCModi.hs
|
|
@ -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 }
|
||||
|
|
|
|||
Loading…
Reference in New Issue