Add AsyncSymbolDb to fix runGhcMod race condition for good

src/GHCMod.hs

@@ -11,6 +11,7 @@ import Language.Haskell.GhcMod
 import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Find (AsyncSymbolDb, newAsyncSymbolDb, getAsyncSymbolDb)
 import System.FilePath ((</>))
 import System.Directory (setCurrentDirectory, getAppUserDataDirectory,
                         removeDirectoryRecursive)
@@ -20,8 +21,6 @@ import Text.PrettyPrint hiding ((<>))
 import GHCMod.Options
 import Prelude
 
-import Misc
-
 ghcModStyle :: Style
 ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 }
 
@@ -49,17 +48,14 @@ progMain (globalOptions, commands) = runGmOutT globalOptions $
 -- ghc-modi
 legacyInteractive :: IOish m => GhcModT m ()
 legacyInteractive = do
-    opt <- options
     prepareCabalHelper
     tmpdir <- cradleTempDir <$> cradle
-    gmo <- gmoAsk
-    symdbreq <- liftIO $ newSymDbReq opt gmo tmpdir
+    asyncSymbolDb <- newAsyncSymbolDb tmpdir
     world <- getCurrentWorld
-    legacyInteractiveLoop symdbreq world
+    legacyInteractiveLoop asyncSymbolDb world
 
-legacyInteractiveLoop :: IOish m
-                      => SymDbReq -> World -> GhcModT m ()
-legacyInteractiveLoop symdbreq world = do
+legacyInteractiveLoop :: IOish m => AsyncSymbolDb -> World -> GhcModT m ()
+legacyInteractiveLoop asyncSymbolDb world = do
     liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle
 
     -- blocking
@@ -80,12 +76,12 @@ legacyInteractiveLoop symdbreq world = do
               $ parseArgsInteractive cmdArg
       case pargs of
         CmdFind symbol ->
-            lookupSymbol symbol =<< checkDb symdbreq =<< getDb symdbreq
+            lookupSymbol symbol =<< getAsyncSymbolDb asyncSymbolDb
         -- other commands are handled here
         x              -> ghcCommands x
 
     gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout)
-    legacyInteractiveLoop symdbreq world'
+    legacyInteractiveLoop asyncSymbolDb world'
  where
     interactiveHandlers =
           [ GHandler $ \(e :: ExitCode) -> throw e

src/Misc.hs

@@ -1,48 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-module Misc (
-    SymDbReq
-  , newSymDbReq
-  , getDb
-  , checkDb
-  ) where
-
-import Control.Concurrent.Async (Async, async, wait)
-import Data.IORef (IORef, newIORef, readIORef, writeIORef)
-import Prelude
-
-import Language.Haskell.GhcMod
-import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
-import Language.Haskell.GhcMod.Types
-import Language.Haskell.GhcMod.Monad
-
-----------------------------------------------------------------
-
-type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog)
-data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction)
-
-newSymDbReq :: Options -> GhcModOut -> FilePath -> IO SymDbReq
-newSymDbReq opt gmo tmpdir = do
-    let act = runGmOutT' gmo $ runGhcModT opt $ loadSymbolDb tmpdir
-    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 <- 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