Emit LSP custom messages on kick start/finish

useful to synchonize on these events in tests

Author: pepeiborra

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

@@ -27,6 +27,7 @@ import           Development.IDE.Graph
 
 import           Control.Concurrent.STM.Stats             (atomically,
                                                            modifyTVar')
+import           Data.Aeson                               (toJSON)
 import qualified Data.ByteString                          as BS
 import           Data.Maybe                               (catMaybes)
 import           Development.IDE.Core.ProgressReporting
@@ -36,6 +37,9 @@ import           Development.IDE.Plugin.Completions.Types
 import           Development.IDE.Types.Exports
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Logger
+import           Development.IDE.Types.Options            (IdeTesting (..))
+import qualified Language.LSP.Server                      as LSP
+import qualified Language.LSP.Types                       as LSP
 
 newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus))
 instance IsIdeGlobal OfInterestVar
@@ -110,7 +114,13 @@ scheduleGarbageCollection state = do
 kick :: Action ()
 kick = do
     files <- HashMap.keys <$> getFilesOfInterestUntracked
-    ShakeExtras{exportsMap, progress} <- getShakeExtras
+    ShakeExtras{exportsMap, ideTesting = IdeTesting testing, lspEnv, progress} <- getShakeExtras
+    let signal msg = when testing $ liftIO $
+            mRunLspT lspEnv $
+                LSP.sendNotification (LSP.SCustomMethod msg) $
+                toJSON $ map fromNormalizedFilePath files
+
+    signal "kick/start"
     liftIO $ progressUpdate progress KickStarted
 
     -- Update the exports map
@@ -129,3 +139,5 @@ kick = do
     when garbageCollectionScheduled $ do
         void garbageCollectDirtyKeys
         liftIO $ writeVar var False
+
+    signal "kick/done"

hls-test-utils/src/Test/Hls.hs

@@ -28,16 +28,21 @@ module Test.Hls
     waitForTypecheck,
     waitForAction,
     sendConfigurationChanged,
-    getLastBuildKeys)
+    getLastBuildKeys,
+    waitForKickDone,
+    waitForKickStart,
+    )
 where
 
 import           Control.Applicative.Combinators
 import           Control.Concurrent.Async        (async, cancel, wait)
 import           Control.Concurrent.Extra
 import           Control.Exception.Base
-import           Control.Monad                   (unless, void)
+import           Control.Monad                   (guard, unless, void)
 import           Control.Monad.IO.Class
-import           Data.Aeson                      (Value (Null), toJSON)
+import           Data.Aeson                      (Result (Success),
+                                                  Value (Null), fromJSON,
+                                                  toJSON)
 import qualified Data.Aeson                      as A
 import           Data.ByteString.Lazy            (ByteString)
 import           Data.Default                    (def)
@@ -247,3 +252,22 @@ getLastBuildKeys = callTestPlugin GetBuildKeysBuilt
 sendConfigurationChanged :: Value -> Session ()
 sendConfigurationChanged config =
   sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams config)
+
+waitForKickDone :: Session ()
+waitForKickDone = void $ skipManyTill anyMessage nonTrivialKickDone
+
+waitForKickStart :: Session ()
+waitForKickStart = void $ skipManyTill anyMessage nonTrivialKickStart
+
+nonTrivialKickDone :: Session ()
+nonTrivialKickDone = kick "done" >>= guard . not . null
+
+nonTrivialKickStart :: Session ()
+nonTrivialKickStart = kick "start" >>= guard . not . null
+
+kick :: T.Text -> Session [FilePath]
+kick msg = do
+  NotMess NotificationMessage{_params} <- customNotification $ "kick/" <> msg
+  case fromJSON _params of
+    Success x -> return x
+    other     -> error $ "Failed to parse kick/done details: " <> show other