backwards compat.

Author: pepeiborra

ghcide/bench/lib/Experiments.hs

@@ -26,6 +26,7 @@ import           Control.Exception.Safe          (IOException, handleAny, try)
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
 import           Data.Aeson                      (Value (Null), toJSON)
+import           Data.Either                     (fromRight)
 import           Data.List
 import           Data.Maybe
 import qualified Data.Text                       as T
@@ -496,10 +497,10 @@ runBench runSess b = handleAny (\e -> print e >> return badRun)
           (userWaits, delayedWork) = fromMaybe (0,0) result
 
       rulesTotal <- length <$> getStoredKeys
-      rulesBuilt <- length <$> getBuildKeysBuilt
-      rulesChanged <- length <$> getBuildKeysChanged
-      rulesVisited <- length <$> getBuildKeysVisited
-      edgesTotal   <- getBuildEdgesCount
+      rulesBuilt <- either (const 0) length <$> getBuildKeysBuilt
+      rulesChanged <- either (const 0) length <$> getBuildKeysChanged
+      rulesVisited <- either (const 0) length <$> getBuildKeysVisited
+      edgesTotal   <- fromRight 0 <$> getBuildEdgesCount
 
       return BenchRun {..}
 

ghcide/test/src/Development/IDE/Test.hs

@@ -181,32 +181,40 @@ canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePat
 diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics)
 diagnostic = LspTest.message STextDocumentPublishDiagnostics
 
-callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b
-callTestPlugin cmd = do
+tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)
+tryCallTestPlugin cmd = do
     let cm = SCustomMethod "test"
     waitId <- sendRequest cm (A.toJSON cmd)
     ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId
     return $ case _result of
-         Left (ResponseError t err _) -> error $ show t <> ": " <> T.unpack err
+         Left e -> Left e
          Right json -> case A.fromJSON json of
-             A.Success a -> a
+             A.Success a -> Right a
              A.Error e   -> error e
 
+callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b
+callTestPlugin cmd = do
+    res <- tryCallTestPlugin cmd
+    case res of
+        Left (ResponseError t err _) -> error $ show t <> ": " <> T.unpack err
+        Right a                      -> pure a
+
+
 waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResult
 waitForAction key TextDocumentIdentifier{_uri} =
     callTestPlugin (WaitForIdeRule key _uri)
 
-getBuildKeysBuilt :: Session [T.Text]
-getBuildKeysBuilt = callTestPlugin GetBuildKeysBuilt
+getBuildKeysBuilt :: Session (Either ResponseError [T.Text])
+getBuildKeysBuilt = tryCallTestPlugin GetBuildKeysBuilt
 
-getBuildKeysVisited :: Session [T.Text]
-getBuildKeysVisited = callTestPlugin GetBuildKeysVisited
+getBuildKeysVisited :: Session (Either ResponseError [T.Text])
+getBuildKeysVisited = tryCallTestPlugin GetBuildKeysVisited
 
-getBuildKeysChanged :: Session [T.Text]
-getBuildKeysChanged = callTestPlugin GetBuildKeysChanged
+getBuildKeysChanged :: Session (Either ResponseError [T.Text])
+getBuildKeysChanged = tryCallTestPlugin GetBuildKeysChanged
 
-getBuildEdgesCount :: Session Int
-getBuildEdgesCount = callTestPlugin GetBuildEdgesCount
+getBuildEdgesCount :: Session (Either ResponseError Int)
+getBuildEdgesCount = tryCallTestPlugin GetBuildEdgesCount
 
 getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath
 getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri)