Attempt to fix logic to only allow one cradle to be running at once.

mpickering · mpickering · commit 256f8b50415a · 2020-04-23T08:41:36.000+01:00
diff --git a/exe/Main.hs b/exe/Main.hs
@@ -62,6 +62,7 @@ import Data.Either
 import qualified Crypto.Hash.SHA1               as H
 import qualified Data.ByteString.Char8          as B
 import           Data.ByteString.Base16         (encode)
+import Control.Concurrent.Async
 
 import           DynFlags                       (gopt_set, gopt_unset,
                                                  updOptLevel)
@@ -346,7 +347,6 @@ loadSession dir = liftIO $ do
         return res
 
     lock <- newLock
-    cradle_lock <- newLock
 
     -- This caches the mapping from hie.yaml + Mod.hs -> [String]
     sessionOpts <- return $ \(hieYaml, file) -> do
@@ -373,17 +373,39 @@ loadSession dir = liftIO $ do
                 finished_barrier <- newBarrier
                 -- fork a new thread here which won't be killed by shake
                 -- throwing an async exception
-                void $ forkIO $ withLock cradle_lock $ do
-                  putStrLn $ "Shelling out to cabal " <> show file
+                void $ forkIO $ do
+                  putStrLn $ "Consulting the cradle for " <> show file
                   cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml
                   opts <- cradleToSessionOpts cradle cfp
                   print opts
                   res <- fst <$> session (hieYaml, toNormalizedFilePath' cfp, opts)
                   signalBarrier finished_barrier res
                 waitBarrier finished_barrier
-    return $ \file -> liftIO $ mask_ $ withLock lock $ do
-              hieYaml <- cradleLoc file
-              sessionOpts (hieYaml, file)
+
+    dummyAs <- async $ return (error "Uninitialised")
+    runningCradle <- newIORef dummyAs
+    -- The main function which gets options for a file. We only want one of these running
+    -- at a time.
+    let getOptions file = do
+            hieYaml <- cradleLoc file
+            sessionOpts (hieYaml, file)
+    -- The lock is on the `runningCradle` resource
+    return $ \file -> liftIO $ withLock lock $ do
+        as <- readIORef runningCradle
+        finished <- poll as
+        case finished of
+            Just {} -> do
+                as <- async $ getOptions file
+                writeIORef runningCradle as
+                wait as
+             -- If it's not finished then wait and then get options, this could of course be killed still
+            Nothing -> do
+                _ <- wait as
+                getOptions file
+
+
+
+
 
 checkDependencyInfo :: Map.Map FilePath (Maybe UTCTime) -> IO Bool
 checkDependencyInfo old_di = do
diff --git a/ghcide.cabal b/ghcide.cabal
@@ -176,6 +176,7 @@ executable ghcide
     main-is: Main.hs
     build-depends:
         time,
+        async,
         hslogger,
         aeson,
         base == 4.*,
