apply feedbacks

Author: pepeiborra

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

@@ -32,6 +32,7 @@ import           Control.Monad.Trans.Maybe
 import qualified Data.ByteString.Lazy                         as LBS
 import           Data.List.Extra                              (nubOrd)
 import           Data.Maybe                                   (catMaybes)
+import           Development.IDE.Core.ProgressReporting
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Shake
 import           Development.IDE.Import.DependencyInformation
@@ -95,8 +96,8 @@ modifyFilesOfInterest state f = do
 kick :: Action ()
 kick = do
     files <- HashMap.keys <$> getFilesOfInterest
-    ShakeExtras{progressUpdate} <- getShakeExtras
-    liftIO $ progressUpdate KickStarted
+    ShakeExtras{progress} <- getShakeExtras
+    liftIO $ progressUpdate progress KickStarted
 
     -- Update the exports map for FOIs
     results <- uses GenerateCore files <* uses GetHieAst files
@@ -116,4 +117,4 @@ kick = do
         !exportsMap'' = maybe mempty createExportsMap ifaces
     void $ liftIO $ modifyVar' exportsMap $ (exportsMap'' <>) . (exportsMap' <>)
 
-    liftIO $ progressUpdate KickCompleted
+    liftIO $ progressUpdate progress KickCompleted

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

@@ -53,8 +53,10 @@ noProgressReporting = return $ ProgressReporting
 
 -- | A 'ProgressReporting' that sends the WorkDone Begin and End notifications
 --   synchronously. Progress notifications are sent from a sampling thread.
+--
+--  This 'ProgressReporting' is currently used only in tests.
 directProgressReporting
-    :: Double -- ^ sampling rate
+    :: Seconds -- ^ sampling rate
     -> Maybe (LSP.LanguageContextEnv config)
     -> ProgressReportingStyle
     -> IO ProgressReporting
@@ -64,8 +66,11 @@ directProgressReporting sample env style = do
 
     let progressUpdate KickStarted = do
           u <- newProgressToken
-          writeIORef st (Just u)
-          mRunLspT env $ start u
+          mRunLspT env $ do
+              ready <- create u
+              for_ ready $ \_ -> do
+                  start u
+                  liftIO $ writeIORef st (Just u)
         progressUpdate KickCompleted = do
             mbToken <- atomicModifyIORef st (Nothing,)
             for_ mbToken $ \u ->
@@ -78,17 +83,17 @@ directProgressReporting sample env style = do
         f file shift = atomicModifyIORef'_ inProgressVar $
                 HMap.insertWith (\_ x -> shift x) file (shift 0)
 
-        progressLoop :: Double -> LSP.LspM a ()
+        progressLoop :: Seconds -> LSP.LspM a ()
         progressLoop prev = do
             mbToken <- liftIO $ readIORef st
-            case mbToken of
+            next <- case mbToken of
                 Nothing ->
-                    liftIO (sleep sample) >> progressLoop 0
+                    pure 0
                 Just t -> do
                     current <- liftIO $ readIORef inProgressVar
-                    prev <- progress style prev current t
-                    liftIO $ sleep sample
-                    progressLoop prev
+                    progress style prev current t
+            liftIO $ sleep sample
+            progressLoop next
 
     progressThread <- async $ mRunLspT env $ progressLoop 0
     let progressStop = cancel progressThread
@@ -100,7 +105,7 @@ directProgressReporting sample env style = do
 --   before the end of the grace period).
 --   Avoid using in tests where progress notifications are used to assert invariants.
 delayedProgressReporting
-  :: Double  -- ^ sampling rate, also used as grace period before Begin
+  :: Seconds  -- ^ sampling rate, also used as grace period before Begin
   -> Maybe (LSP.LanguageContextEnv c)
   -> ProgressReportingStyle
   -> IO ProgressReporting
@@ -121,6 +126,9 @@ delayedProgressReporting sample lspEnv style = do
     -- And two transitions, modelled by 'ProgressEvent':
     --   1. KickCompleted - transitions from Reporting into Idle
     --   2. KickStarted - transitions from Idle into Reporting
+    -- When transitioning from Idle to Reporting a new async is spawned that
+    -- sends progress updates in a loop. The async is cancelled when transitioning
+    -- from Reporting to Idle.
     progressThread mostRecentProgressEvent inProgress = progressLoopIdle
       where
         progressLoopIdle = do
@@ -147,10 +155,10 @@ delayedProgressReporting sample lspEnv style = do
     lspShakeProgress style inProgress = do
         u <- liftIO newProgressToken
 
-        void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate
-            LSP.WorkDoneProgressCreateParams { _token = u } $ const (pure ())
+        ready <- create u
 
-        bracket_ (start u) (stop u) (loop u 0)
+        for_ ready $ \_ ->
+          bracket_ (start u) (stop u) (loop u 0)
         where
             loop id prev = do
                 liftIO $ sleep sample
@@ -167,6 +175,16 @@ delayedProgressReporting sample lspEnv style = do
 newProgressToken :: IO ProgressToken
 newProgressToken = ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique
 
+create
+    :: LSP.MonadLsp config f
+    => ProgressToken
+    -> f (Either ResponseError Empty)
+create u = do
+    b <- liftIO newBarrier
+    _ <- LSP.sendRequest LSP.SWindowWorkDoneProgressCreate
+            LSP.WorkDoneProgressCreateParams { _token = u }
+            (liftIO . signalBarrier b)
+    liftIO $ waitBarrier b
 
 start :: LSP.MonadLsp config f => ProgressToken -> f ()
 start id = LSP.sendNotification LSP.SProgress $
@@ -189,7 +207,7 @@ stop id = LSP.sendNotification LSP.SProgress
         }
 
 progress :: (LSP.MonadLsp config f) =>
-  ProgressReportingStyle -> Double -> HashMap NormalizedFilePath Int -> ProgressToken -> f Double
+  ProgressReportingStyle -> Seconds -> HashMap NormalizedFilePath Int -> ProgressToken -> f Seconds
 progress style prev current id = do
     let done = length $ filter (== 0) $ HMap.elems current
     let todo = HMap.size current

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

@@ -183,9 +183,7 @@ data ShakeExtras = ShakeExtras
     -- positions in a version of that document to positions in the latest version
     -- First mapping is delta from previous version and second one is an
     -- accumlation of all previous mappings.
-    ,inProgress :: forall a . NormalizedFilePath -> Action a -> Action a
-    -- ^ Report progress for a rule
-    ,progressUpdate :: ProgressEvent -> IO ()
+    ,progress :: ProgressReporting
     ,ideTesting :: IdeTesting
     -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants
     ,restartShakeSession :: [DelayedAction ()] -> IO ()
@@ -378,12 +376,11 @@ newtype ShakeSession = ShakeSession
 -- | A Shake database plus persistent store. Can be thought of as storing
 --   mappings from @(FilePath, k)@ to @RuleResult k@.
 data IdeState = IdeState
-    {shakeDb               :: ShakeDatabase
-    ,shakeSession          :: MVar ShakeSession
-    ,shakeClose            :: IO ()
-    ,shakeExtras           :: ShakeExtras
-    ,shakeDatabaseProfile  :: ShakeDatabase -> IO (Maybe FilePath)
-    ,stopProgressReporting :: IO ()
+    {shakeDb              :: ShakeDatabase
+    ,shakeSession         :: MVar ShakeSession
+    ,shakeClose           :: IO ()
+    ,shakeExtras          :: ShakeExtras
+    ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath)
     }
 
 
@@ -473,7 +470,7 @@ shakeOpen lspEnv defaultConfig logger debouncer
 
     us <- mkSplitUniqSupply 'r'
     ideNc <- newIORef (initNameCache us knownKeyNames)
-    (shakeExtras, stopProgressReporting) <- do
+    shakeExtras <- do
         globals <- newVar HMap.empty
         state <- newVar HMap.empty
         diagnostics <- newVar mempty
@@ -489,7 +486,7 @@ shakeOpen lspEnv defaultConfig logger debouncer
         let hiedbWriter = HieDbWriter{..}
         exportsMap <- newVar mempty
 
-        ProgressReporting{..} <-
+        progress <-
             if reportProgress
                 then (if testing
                         then directProgressReporting
@@ -499,9 +496,8 @@ shakeOpen lspEnv defaultConfig logger debouncer
         actionQueue <- newQueue
 
         let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv
-            extras = ShakeExtras{..}
 
-        pure (extras, progressStop)
+        pure ShakeExtras{..}
     (shakeDbM, shakeClose) <-
         shakeOpenDatabase
             opts { shakeExtra = newShakeExtra shakeExtras }
@@ -534,7 +530,7 @@ shakeShut IdeState{..} = withMVar shakeSession $ \runner -> do
     -- request so we first abort that.
     void $ cancelShakeSession runner
     shakeClose
-    stopProgressReporting
+    progressStop $ progress shakeExtras
 
 
 -- | This is a variant of withMVar where the first argument is run unmasked and if it throws
@@ -849,9 +845,9 @@ defineEarlyCutoff'
     -> Action (Maybe BS.ByteString, IdeResult v)
     -> Action (RunResult (A (RuleResult k)))
 defineEarlyCutoff' doDiagnostics key file old mode action = do
-    extras@ShakeExtras{state, inProgress, logger} <- getShakeExtras
+    extras@ShakeExtras{state, progress, logger} <- getShakeExtras
     options <- getIdeOptions
-    (if optSkipProgress options key then id else inProgress file) $ do
+    (if optSkipProgress options key then id else inProgress progress file) $ do
         val <- case old of
             Just old | mode == RunDependenciesSame -> do
                 v <- liftIO $ getValues state key file