Add AsyncSymbolDb to fix runGhcMod race condition for good

Language/Haskell/GhcMod/Find.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse #-}
+{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, MultiWayIf #-}
 
 module Language.Haskell.GhcMod.Find
 #ifndef SPEC
@@ -10,34 +10,42 @@ module Language.Haskell.GhcMod.Find
   , findSymbol
   , lookupSym
   , isOutdated
+  -- * Load 'SymbolDb' asynchronously
+  , AsyncSymbolDb
+  , newAsyncSymbolDb
+  , getAsyncSymbolDb
   )
 #endif
   where
 
-import Control.Applicative
-import Control.Monad (when, void)
-import Data.Function (on)
-import Data.List (groupBy, sort)
-import qualified GHC as G
 import Language.Haskell.GhcMod.Convert
-import Language.Haskell.GhcMod.Gap (listVisibleModules)
+import Language.Haskell.GhcMod.Gap
 import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Output
 import Language.Haskell.GhcMod.PathsAndFiles
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils
-import Language.Haskell.GhcMod.World (timedPackageCaches)
-import Language.Haskell.GhcMod.Output
-import Name (getOccString)
-import Module (moduleName)
-import System.Directory (doesFileExist)
+import Language.Haskell.GhcMod.World
+
+import qualified GHC as G
+import Name
+import Module
+import Exception
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Trans.Control
+import Control.Concurrent
+import Data.Function
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as M
+import System.Directory
 import System.Directory.ModTime
 import System.FilePath ((</>))
 import System.IO
 import Prelude
 
-import Data.Map (Map)
-import qualified Data.Map as M
-
 ----------------------------------------------------------------
 
 -- | Type of function and operation names.
@@ -147,3 +155,38 @@ collectModules :: [(Symbol, ModuleString)]
 collectModules = map tieup . groupBy ((==) `on` fst) . sort
   where
     tieup x = (head (map fst x), map snd x)
+
+----------------------------------------------------------------
+
+data AsyncSymbolDb = AsyncSymbolDb FilePath (MVar (Either SomeException SymbolDb))
+
+asyncLoadSymbolDb :: IOish m
+                  => FilePath
+                  -> MVar (Either SomeException SymbolDb)
+                  -> GhcModT m ()
+asyncLoadSymbolDb tmpdir mv = void $
+    liftBaseWith $ \run -> forkIO $ void $ run $ do
+      edb <- gtry $ loadSymbolDb tmpdir
+      liftIO $ putMVar mv edb
+
+newAsyncSymbolDb :: IOish m => FilePath -> GhcModT m AsyncSymbolDb
+newAsyncSymbolDb tmpdir = do
+    mv <- liftIO newEmptyMVar
+    asyncLoadSymbolDb tmpdir mv
+    return $ AsyncSymbolDb tmpdir mv
+
+getAsyncSymbolDb :: forall m. IOish m => AsyncSymbolDb -> GhcModT m SymbolDb
+getAsyncSymbolDb (AsyncSymbolDb tmpdir mv) = go 0
+ where
+   go :: Integer -> GhcModT m SymbolDb
+   go i = do
+     edb <- liftIO $ takeMVar mv
+     case edb of
+       Left ex -> throw ex
+       Right db -> do
+         outdated <- isOutdated db
+         if | i > 2 -> error "getAsyncSymbolDb: outdated loop"
+            | outdated -> asyncLoadSymbolDb tmpdir mv >> go (i + 1)
+            | otherwise -> do
+                liftIO $ putMVar mv (Right db)
+                return db

ghc-mod.cabal

@@ -206,7 +206,6 @@ Executable ghc-mod
   Default-Extensions:   ConstraintKinds, FlexibleContexts
   HS-Source-Dirs:       src
   Build-Depends:        base      < 5 && >= 4.0
-                      , async     < 2.1
                       , directory < 1.3
                       , filepath  < 1.5
                       , pretty    < 1.2
@@ -214,6 +213,7 @@ Executable ghc-mod
                       , split     < 0.3
                       , mtl       < 2.3 && >= 2.0
                       , ghc       < 7.11
+                      , monad-control ==1.0.*
                       , fclabels  ==2.0.*
                       , optparse-applicative >=0.11.0 && <0.13.0
                       , ghc-mod
@@ -222,7 +222,6 @@ Executable ghc-modi
   Default-Language:     Haskell2010
   Main-Is:              GHCModi.hs
   Other-Modules:        Paths_ghc_mod
-                        Misc
                         Utils
   GHC-Options:          -Wall -threaded -fno-warn-deprecations
   if os(windows)

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