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

removing target file set from ghc-modi.

Browse Source 
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
1 changed files with 56 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

178
src/GHCModi.hs
View File

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