ghc-modi's "find" now catches up if packageDb is updated.
This commit is contained in:
parent
e66aefebee
commit
e8988c2f02
@ -46,6 +46,7 @@ module Language.Haskell.GhcMod (
|
||||
, dumpSymbol
|
||||
-- * SymbolDb
|
||||
, loadSymbolDb
|
||||
, isOutdated
|
||||
) where
|
||||
|
||||
import Language.Haskell.GhcMod.Boot
|
||||
|
@ -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])]
|
||||
|
@ -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)
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user