ghc-modi's "find" now catches up if packageDb is updated.

This commit is contained in:
Kazu Yamamoto 2014-09-20 12:25:46 +09:00
parent e66aefebee
commit e8988c2f02
3 changed files with 72 additions and 33 deletions

View File

@ -46,6 +46,7 @@ module Language.Haskell.GhcMod (
, dumpSymbol
-- * SymbolDb
, loadSymbolDb
, isOutdated
) where
import Language.Haskell.GhcMod.Boot

View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE CPP, BangPatterns #-}
module Language.Haskell.GhcMod.Find
#ifndef SPEC
@ -10,6 +10,7 @@ module Language.Haskell.GhcMod.Find
, dumpSymbol
, findSymbol
, lookupSym
, isOutdated
)
#endif
where
@ -52,8 +53,14 @@ import qualified Data.Map as M
-- | Type of function and operation names.
type Symbol = String
-- | Database from 'Symbol' to \['ModuleString'\].
newtype SymbolDb = SymbolDb (Map Symbol [ModuleString])
deriving (Show)
data SymbolDb = SymbolDb {
table :: Map Symbol [ModuleString]
, packageCachePath :: FilePath
, symbolDbCachePath :: FilePath
} deriving (Show)
isOutdated :: SymbolDb -> IO Bool
isOutdated db = symbolDbCachePath db `isOlderThan` packageCachePath db
----------------------------------------------------------------
@ -85,13 +92,27 @@ lookupSymbol :: IOish m => Symbol -> SymbolDb -> GhcModT m String
lookupSymbol sym db = convert' $ lookupSym sym db
lookupSym :: Symbol -> SymbolDb -> [ModuleString]
lookupSym sym (SymbolDb db) = fromMaybe [] $ M.lookup sym db
lookupSym sym db = fromMaybe [] $ M.lookup sym $ table db
---------------------------------------------------------------
-- | Loading a file and creates 'SymbolDb'.
loadSymbolDb :: (IOish m, MonadError GhcModError m) => m SymbolDb
loadSymbolDb = SymbolDb <$> readSymbolDb
loadSymbolDb = do
ghcMod <- liftIO ghcModExecutable
file <- chop <$> readProcess' ghcMod ["dumpsym"]
!db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
return $ SymbolDb {
table = db
, packageCachePath = takeDirectory file </> packageCache
, symbolDbCachePath = file
}
where
conv :: String -> (Symbol,[ModuleString])
conv = read
chop "" = ""
chop xs = init xs
-- | Returns the path to the currently running ghc-mod executable. With ghc<7.6
-- this is a guess but >=7.6 uses 'getExecutablePath'.
@ -113,17 +134,6 @@ ghcModExecutable = do _ <- getExecutablePath' -- get rid of unused warning when
getExecutablePath' = return ""
# endif
readSymbolDb :: (IOish m, MonadError GhcModError m) => m (Map Symbol [ModuleString])
readSymbolDb = do
ghcMod <- liftIO ghcModExecutable
file <- chop <$> readProcess' ghcMod ["dumpsym"]
M.fromAscList . map conv . lines <$> liftIO (readFile file)
where
conv :: String -> (Symbol,[ModuleString])
conv = read
chop "" = ""
chop xs = init xs
----------------------------------------------------------------
-- used 'ghc-mod dumpsym'
@ -144,7 +154,7 @@ dumpSymbol = do
let cache = dir </> symbolCache
pkgdb = dir </> packageCache
create <- liftIO $ cache `isNewerThan` pkgdb
create <- liftIO $ cache `isOlderThan` pkgdb
when create $ (liftIO . writeSymbolCache cache) =<< getSymbolTable
return $ unlines [cache]
@ -155,15 +165,15 @@ writeSymbolCache cache sm =
void . withFile cache WriteMode $ \hdl ->
mapM (hPrint hdl) sm
isNewerThan :: FilePath -> FilePath -> IO Bool
isNewerThan ref file = do
exist <- doesFileExist ref
isOlderThan :: FilePath -> FilePath -> IO Bool
isOlderThan cache file = do
exist <- doesFileExist cache
if not exist then
return True
else do
tRef <- getModificationTime ref
tCache <- getModificationTime cache
tFile <- getModificationTime file
return $ tRef <= tFile -- including equal just in case
return $ tCache <= tFile -- including equal just in case
-- | Browsing all functions in all system/user modules.
getSymbolTable :: IOish m => GhcModT m [(Symbol,[ModuleString])]

View File

@ -25,6 +25,7 @@ import Control.Exception (SomeException(..), Exception)
import qualified Control.Exception as E
import Control.Monad (when)
import CoreMonad (liftIO)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.List (intercalate)
import Data.List.Split (splitOn)
import Data.Typeable (Typeable)
@ -35,8 +36,8 @@ import Paths_ghc_mod
import System.Console.GetOpt
import System.Directory (setCurrentDirectory)
import System.Environment (getArgs)
import System.IO (hFlush,stdout)
import System.Exit (ExitCode, exitFailure)
import System.IO (hFlush,stdout)
import Utils
@ -97,8 +98,9 @@ main = E.handle cmdHandler $
let rootdir = cradleRootDir cradle0
-- c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????
setCurrentDirectory rootdir
symDb <- async $ runGhcModT opt loadSymbolDb
(res, _) <- runGhcModT opt $ loop symDb
-- Asynchronous db loading starts here.
symdbreq <- newSymDbReq opt
(res, _) <- runGhcModT opt $ loop symdbreq
case res of
Right () -> return ()
@ -129,13 +131,13 @@ replace needle replacement = intercalate replacement . splitOn needle
----------------------------------------------------------------
loop :: IOish m => SymDbReq -> GhcModT m ()
loop symDbReq = do
loop symdbreq = do
cmdArg <- liftIO getLine
let (cmd,arg') = break (== ' ') cmdArg
arg = dropWhile (== ' ') arg'
(ret,ok) <- case cmd of
"check" -> checkStx arg
"find" -> findSym arg symDbReq
"find" -> findSym arg symdbreq
"lint" -> lintStx arg
"info" -> showInfo arg
"type" -> showType arg
@ -154,7 +156,7 @@ loop symDbReq = do
else do
liftIO $ putStrLn $ notGood ret
liftIO $ hFlush stdout
when ok $ loop symDbReq
when ok $ loop symdbreq
----------------------------------------------------------------
@ -167,12 +169,38 @@ checkStx file = do
----------------------------------------------------------------
type SymDbReq = Async (Either GhcModError SymbolDb, GhcModLog)
type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog)
data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction)
findSym :: IOish m => String -> SymDbReq
-> GhcModT m (String, Bool)
findSym sym dbReq = do
db <- hoistGhcModT =<< liftIO (wait dbReq)
newSymDbReq :: Options -> IO SymDbReq
newSymDbReq opt = do
let act = runGhcModT opt loadSymbolDb
req <- async act
ref <- newIORef req
return $ SymDbReq ref act
getDb :: IOish m => SymDbReq -> GhcModT m SymbolDb
getDb (SymDbReq ref _) = do
req <- liftIO $ readIORef ref
-- 'wait' really waits for the asynchronous action at the fist time.
-- Then it reads a cached value from the second time.
hoistGhcModT =<< liftIO (wait req)
checkDb :: IOish m => SymDbReq -> SymbolDb -> GhcModT m SymbolDb
checkDb (SymDbReq ref act) db = do
outdated <- liftIO $ isOutdated db
if outdated then do
-- async and wait here is unnecessary because this is essentially
-- synchronous. But Async can be used a cache.
req <- liftIO $ async act
liftIO $ writeIORef ref req
hoistGhcModT =<< liftIO (wait req)
else
return db
findSym :: IOish m => Symbol -> SymDbReq -> GhcModT m (String, Bool)
findSym sym symdbreq = do
db <- getDb symdbreq >>= checkDb symdbreq
ret <- lookupSymbol sym db
return (ret, True)