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

Language/Haskell/GhcMod.hs

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

Language/Haskell/GhcMod/Find.hs

@@ -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])
+data SymbolDb = SymbolDb {
-    deriving (Show)
+    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
+isOlderThan :: FilePath -> FilePath -> IO Bool
-isNewerThan ref file = do
+isOlderThan cache file = do
-    exist <- doesFileExist ref
+    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])]

src/GHCModi.hs

@@ -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
+        -- Asynchronous db loading starts here.
-        (res, _) <- runGhcModT opt $ loop symDb
+        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
+newSymDbReq :: Options -> IO SymDbReq
-        -> GhcModT m (String, Bool)
+newSymDbReq opt = do
-findSym sym dbReq = do
+    let act = runGhcModT opt loadSymbolDb
-    db <- hoistGhcModT =<< liftIO (wait dbReq)
+    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)