Helpers for reference/ready message parsing

haskell · Feb 19, 2022 · 6c7fd99 · 6c7fd99
1 parent bf1afd2
commit 6c7fd99
Show file tree

Hide file tree

Showing 2 changed files with 30 additions and 19 deletions.
diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs
@@ -58,7 +58,9 @@ import           Development.IDE.Test                     (Cursor,
                                                            standardizeQuotes,
                                                            waitForAction,
                                                            waitForGC,
-                                                           waitForTypecheck)
+                                                           waitForTypecheck,
+                                                           isReferenceReady,
+                                                           referenceReady)
 import           Development.IDE.Test.Runfiles
 import qualified Development.IDE.Types.Diagnostics        as Diagnostics
 import           Development.IDE.Types.Location
@@ -5543,11 +5545,7 @@ simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi
     adoc <- liftIO $ runInDir dir $ do
       aSource <- liftIO $ readFileUtf8 aPath
       adoc <- createDoc aPath "haskell" aSource
-      ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case
-        FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do
-          A.Success fp' <- pure $ fromJSON fp
-          if equalFilePath fp' aPath then pure () else Nothing
-        _ -> Nothing
+      skipManyTill anyMessage $ isReferenceReady aPath
       closeDoc adoc
       pure adoc
     bSource <- liftIO $ readFileUtf8 bPath
@@ -5578,18 +5576,15 @@ bootTests = testGroup "boot"
             -- `ghcide/reference/ready` notification.
             -- Once we receive one of the above, we wait for the other that we
             -- haven't received yet.
-            -- If we don't wait for the `ready` notification it is possible 
-            -- that the `getDefinitions` request/response in the outer ghcide 
+            -- If we don't wait for the `ready` notification it is possible
+            -- that the `getDefinitions` request/response in the outer ghcide
             -- session will find no definitions.
             let hoverParams = HoverParams cDoc (Position 4 3) Nothing
             hoverRequestId <- sendRequest STextDocumentHover hoverParams
-            let parseReadyMessage = satisfy $ \case
-                  FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = params})
-                    | A.Success fp <- fromJSON params -> equalFilePath fp cPath
-                  _ -> False
+            let parseReadyMessage = isReferenceReady cPath
             let parseHoverResponse = responseForId STextDocumentHover hoverRequestId
             hoverResponseOrReadyMessage <- skipManyTill anyMessage ((Left <$> parseHoverResponse) <|> (Right <$> parseReadyMessage))
-            _ <- skipManyTill anyMessage $ 
+            _ <- skipManyTill anyMessage $
               case hoverResponseOrReadyMessage of
                 Left _ -> void parseReadyMessage
                 Right _ -> void parseHoverResponse
@@ -6002,11 +5997,7 @@ referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "reference
     loop :: [FilePath] -> Session ()
     loop [] = pure ()
     loop docs = do
-      doc <- skipManyTill anyMessage $ satisfyMaybe $ \case
-          FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do
-            A.Success fp' <- pure $ fromJSON fp
-            find (fp' ==) docs
-          _ -> Nothing
+      doc <- skipManyTill anyMessage $ referenceReady (`elem` docs)
       loop (delete doc docs)
   loop docs
   f dir

diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs
@@ -29,7 +29,13 @@ module Development.IDE.Test
   , getStoredKeys
   , waitForCustomMessage
   , waitForGC
-  ,getBuildKeysBuilt,getBuildKeysVisited,getBuildKeysChanged,getBuildEdgesCount,configureCheckProject) where
+  , getBuildKeysBuilt
+  , getBuildKeysVisited
+  , getBuildKeysChanged
+  , getBuildEdgesCount
+  , configureCheckProject
+  , isReferenceReady
+  , referenceReady) where
 
 import           Control.Applicative.Combinators
 import           Control.Lens                    hiding (List)
@@ -58,6 +64,7 @@ import           Language.LSP.Types.Lens         as Lsp
 import           System.Directory                (canonicalizePath)
 import           System.Time.Extra
 import           Test.Tasty.HUnit
+import System.FilePath (equalFilePath)
 
 requireDiagnosticM
     :: (Foldable f, Show (f Diagnostic), HasCallStack)
@@ -254,3 +261,16 @@ configureCheckProject overrideCheckProject =
     sendNotification SWorkspaceDidChangeConfiguration
         (DidChangeConfigurationParams $ toJSON
             def{checkProject = overrideCheckProject})
+
+-- | Pattern match a message from ghcide indicating that a file has been indexed
+isReferenceReady :: FilePath -> Session ()
+isReferenceReady p = void $ referenceReady (equalFilePath p)
+
+referenceReady :: (FilePath -> Bool) -> Session FilePath
+referenceReady pred = satisfyMaybe $ \case
+  FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params})
+    | A.Success fp <- A.fromJSON _params
+    , pred fp
+    -> Just fp
+  _ -> Nothing
+