lock-less progress-reporting

ghcide/ghcide.cabal

@@ -385,6 +385,7 @@ test-suite ghcide-tests
         hls-plugin-api,
         network-uri,
         lens,
+        list-t,
         lsp-test ^>= 0.14,
         optparse-applicative,
         process,
@@ -395,6 +396,8 @@ test-suite ghcide-tests
         safe,
         safe-exceptions,
         shake,
+        stm,
+        stm-containers,
         hls-graph,
         tasty,
         tasty-expected-failure,

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

@@ -9,27 +9,31 @@ module Development.IDE.Core.ProgressReporting
   , mRunLspTCallback
   -- for tests
   , recordProgress
-  , InProgress(..)
+  , InProgressState(..)
   )
    where
 
 import           Control.Concurrent.Async
+import           Control.Concurrent.STM.Stats   (STM, TVar, atomically,
+                                                 newTVarIO, readTVar,
+                                                 readTVarIO, writeTVar)
 import           Control.Concurrent.Strict
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class      (lift)
 import           Data.Foldable                  (for_)
 import           Data.Functor                   (($>))
-import qualified Data.HashMap.Strict            as HMap
 import qualified Data.Text                      as T
 import           Data.Unique
 import           Development.IDE.GHC.Orphans    ()
 import           Development.IDE.Graph          hiding (ShakeValue)
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
+import qualified Focus
 import qualified Language.LSP.Server            as LSP
 import           Language.LSP.Types
 import qualified Language.LSP.Types             as LSP
+import qualified StmContainers.Map              as STM
 import           System.Time.Extra
 import           UnliftIO.Exception             (bracket_)
 
@@ -69,26 +73,37 @@ updateState _     StopProgress          (Running a) = cancel a $> Stopped
 updateState _     StopProgress          st          = pure st
 
 -- | Data structure to track progress across the project
-data InProgress = InProgress
-    { todo    :: !Int  -- ^ Number of files to do
-    , done    :: !Int  -- ^ Number of files done
-    , current :: !(HMap.HashMap NormalizedFilePath Int)
+data InProgressState = InProgressState
+    { todoVar    :: TVar Int  -- ^ Number of files to do
+    , doneVar    :: TVar Int  -- ^ Number of files done
+    , currentVar :: STM.Map NormalizedFilePath Int
     }
 
-recordProgress :: NormalizedFilePath -> (Int -> Int) -> InProgress -> InProgress
-recordProgress file shift InProgress{..} = case HMap.alterF alter file current of
-    ((prev, new), m') ->
-        let (done',todo') =
-                case (prev,new) of
-                    (Nothing,0) -> (done+1, todo+1)
-                    (Nothing,_) -> (done,   todo+1)
-                    (Just 0, 0) -> (done  , todo)
-                    (Just 0, _) -> (done-1, todo)
-                    (Just _, 0) -> (done+1, todo)
-                    (Just _, _) -> (done  , todo)
-        in InProgress todo' done' m'
+newInProgress :: IO InProgressState
+newInProgress = InProgressState <$> newTVarIO 0 <*> newTVarIO 0 <*> STM.newIO
+
+recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int) -> STM ()
+recordProgress InProgressState{..} file shift = do
+    done <- readTVar doneVar
+    todo <- readTVar todoVar
+    (prev, new) <- STM.focus alterPrevAndNew file currentVar
+    let (done',todo') =
+            case (prev,new) of
+                (Nothing,0) -> (done+1, todo+1)
+                (Nothing,_) -> (done,   todo+1)
+                (Just 0, 0) -> (done  , todo)
+                (Just 0, _) -> (done-1, todo)
+                (Just _, 0) -> (done+1, todo)
+                (Just _, _) -> (done  , todo)
+    writeTVar todoVar todo'
+    writeTVar doneVar done'
   where
-    alter x = let x' = maybe (shift 0) shift x in ((x,x'), Just x')
+    alterPrevAndNew = do
+        prev <- Focus.lookup
+        Focus.alter alter
+        new <- Focus.lookupWithDefault 0
+        return (prev, new)
+    alter x = let x' = maybe (shift 0) shift x in Just x'
 
 -- | A 'ProgressReporting' that enqueues Begin and End notifications in a new
 --   thread, with a grace period (nothing will be sent if 'KickCompleted' arrives
@@ -100,17 +115,16 @@ delayedProgressReporting
   -> ProgressReportingStyle
   -> IO ProgressReporting
 delayedProgressReporting before after lspEnv optProgressStyle = do
-    inProgressVar <- newVar $ InProgress 0 0 mempty
+    inProgressState <- newInProgress
     progressState <- newVar NotStarted
     let progressUpdate event = updateStateVar $ Event event
         progressStop   =  updateStateVar StopProgress
-        updateStateVar = modifyVar_ progressState . updateState (mRunLspT lspEnv $ lspShakeProgress inProgressVar)
+        updateStateVar = modifyVar_ progressState . updateState (mRunLspT lspEnv $ lspShakeProgress inProgressState)
 
-        inProgress :: NormalizedFilePath -> Action a -> Action a
-        inProgress = withProgressVar inProgressVar
+        inProgress = updateStateForFile inProgressState
     return ProgressReporting{..}
     where
-        lspShakeProgress inProgress = do
+        lspShakeProgress InProgressState{..} = do
             -- first sleep a bit, so we only show progress messages if it's going to take
             -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)
             liftIO $ sleep before
@@ -143,7 +157,8 @@ delayedProgressReporting before after lspEnv optProgressStyle = do
                 loop _ _ | optProgressStyle == NoProgress =
                     forever $ liftIO $ threadDelay maxBound
                 loop id prev = do
-                    InProgress{..} <- liftIO $ readVar inProgress
+                    done <- liftIO $ readTVarIO doneVar
+                    todo <- liftIO $ readTVarIO todoVar
                     liftIO $ sleep after
                     if todo == 0 then loop id 0 else do
                         let next = 100 * fromIntegral done / fromIntegral todo
@@ -166,12 +181,12 @@ delayedProgressReporting before after lspEnv optProgressStyle = do
                               }
                         loop id next
 
-        withProgressVar var file = actionBracket (f succ) (const $ f pred) . const
+        updateStateForFile inProgress file = actionBracket (f succ) (const $ f pred) . const
             -- This functions are deliberately eta-expanded to avoid space leaks.
             -- 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 = atomically $ recordProgress inProgress file shift
 
 mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m ()
 mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f

ghcide/test/exe/Progress.hs

@@ -1,7 +1,13 @@
+{-# LANGUAGE PackageImports #-}
 module Progress (tests) where
 
+import           Control.Concurrent.STM
+import           Data.Foldable                          (for_)
 import qualified Data.HashMap.Strict                    as Map
+import           Development.IDE                        (NormalizedFilePath)
 import           Development.IDE.Core.ProgressReporting
+import qualified "list-t" ListT
+import qualified StmContainers.Map                      as STM
 import           Test.Tasty
 import           Test.Tasty.HUnit
 
@@ -10,6 +16,11 @@ tests = testGroup "Progress"
     [ reportProgressTests
     ]
 
+data InProgressModel = InProgressModel {
+    done, todo :: Int,
+    current    :: Map.HashMap NormalizedFilePath Int
+}
+
 reportProgressTests :: TestTree
 reportProgressTests = testGroup "recordProgress"
     [ test "addNew"   addNew
@@ -18,11 +29,32 @@ reportProgressTests = testGroup "recordProgress"
     , test "done" done
     ]
     where
-        p0 = InProgress 0 0 mempty
-        addNew = recordProgress "A" succ p0
-        increase = recordProgress "A" succ addNew
-        decrease = recordProgress "A" succ increase
-        done = recordProgress "A" pred decrease
-        model InProgress{..} =
+        p0 = pure $ InProgressModel 0 0 mempty
+        addNew = recordProgressModel "A" succ p0
+        increase = recordProgressModel "A" succ addNew
+        decrease = recordProgressModel "A" succ increase
+        done = recordProgressModel "A" pred decrease
+        recordProgressModel key change state =
+            model state $ \st -> recordProgress st key change
+        model stateModelIO k = do
+            state <- fromModel =<< stateModelIO
+            k state
+            toModel state
+        test name p = testCase name $ do
+            InProgressModel{..} <- p
             (done, todo) @?= (length (filter (==0) (Map.elems current)), Map.size current)
-        test name p = testCase name $ model p
+
+fromModel :: InProgressModel -> IO InProgressState
+fromModel InProgressModel{..} = do
+    doneVar <- newTVarIO done
+    todoVar <- newTVarIO todo
+    currentVar <- STM.newIO
+    atomically $ for_ (Map.toList current) $ \(k,v) -> STM.insert v k currentVar
+    return InProgressState{..}
+
+toModel :: InProgressState -> IO InProgressModel
+toModel InProgressState{..} = atomically $ do
+    done <- readTVar doneVar
+    todo <- readTVar todoVar
+    current <- Map.fromList <$> ListT.toList (STM.listT currentVar)
+    return InProgressModel{..}