migrate to MVar

Author: pepeiborra

ghcide/src/Development/IDE/Core/ProgressReporting.hs

@@ -22,6 +22,7 @@ import           Data.Foldable                  (for_)
 import           Data.Functor                   (($>))
 import qualified Data.HashMap.Strict            as HMap
 import qualified Data.Text                      as T
+import           Data.Tuple.Extra               (dupe)
 import           Data.Unique
 import           Development.IDE.GHC.Orphans    ()
 import           Development.IDE.Graph          hiding (ShakeValue)
@@ -31,7 +32,7 @@ import qualified Language.LSP.Server            as LSP
 import           Language.LSP.Types
 import qualified Language.LSP.Types             as LSP
 import           System.Time.Extra
-import           UnliftIO.Exception             (bracket_)
+import           UnliftIO.Exception             (bracket_, evaluate)
 
 data ProgressEvent
     = KickStarted
@@ -100,11 +101,11 @@ delayedProgressReporting
   -> ProgressReportingStyle
   -> IO ProgressReporting
 delayedProgressReporting before after lspEnv optProgressStyle = do
-    inProgressVar <- newVar $ InProgress 0 0 mempty
-    progressState <- newVar NotStarted
+    inProgressVar <- newMVar $ InProgress 0 0 mempty
+    progressState <- newMVar NotStarted
     let progressUpdate event = updateStateVar $ Event event
         progressStop   =  updateStateVar StopProgress
-        updateStateVar = modifyVar_ progressState . updateState (mRunLspT lspEnv $ lspShakeProgress inProgressVar)
+        updateStateVar = modifyMVar_ progressState . updateState (mRunLspT lspEnv $ lspShakeProgress inProgressVar)
 
         inProgress :: NormalizedFilePath -> Action a -> Action a
         inProgress = withProgressVar inProgressVar
@@ -116,10 +117,10 @@ delayedProgressReporting before after lspEnv optProgressStyle = do
             liftIO $ sleep before
             u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique
 
-            b <- liftIO newBarrier
+            b <- liftIO newEmptyMVar
             void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate
-                LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b
-            ready <- liftIO $ waitBarrier b
+                LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . putMVar b
+            ready <- liftIO $ takeMVar b
 
             for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0)
             where
@@ -143,7 +144,7 @@ delayedProgressReporting before after lspEnv optProgressStyle = do
                 loop _ _ | optProgressStyle == NoProgress =
                     forever $ liftIO $ threadDelay maxBound
                 loop id prev = do
-                    InProgress{..} <- liftIO $ readVar inProgress
+                    InProgress{..} <- liftIO $ readMVar inProgress
                     liftIO $ sleep after
                     if todo == 0 then loop id 0 else do
                         let next = 100 * fromIntegral done / fromIntegral todo
@@ -171,7 +172,7 @@ delayedProgressReporting before after lspEnv optProgressStyle = do
             -- Do not remove the eta-expansion without profiling a session with at
             -- least 1000 modifications.
             where
-              f shift = modifyVar' var $ recordProgress file shift
+              f shift = modifyMVar var $ evaluate . dupe . recordProgress file shift
 
 mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m ()
 mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f