Helpers for reference/ready message parsing

Author: pepeiborra

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
@@ -5534,11 +5536,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
@@ -5566,11 +5564,7 @@ bootTests = testGroup "boot"
         liftIO $ runInDir dir $ do
             cDoc <- createDoc cPath "haskell" cSource
             _ <- getHover cDoc $ Position 4 3
-            ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case
-                FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do
-                    A.Success fp' <- pure $ fromJSON fp
-                    if equalFilePath fp' cPath then pure () else Nothing
-                _ -> Nothing
+            skipManyTill anyMessage $ isReferenceReady cPath
             closeDoc cDoc
         cdoc <- createDoc cPath "haskell" cSource
         locs <- getDefinitions cdoc (Position 7 4)
@@ -5980,11 +5974,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

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)
@@ -254,3 +260,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 (==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
+