getLastBuildKeys

Author: pepeiborra

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

@@ -24,7 +24,7 @@
 --   always stored as real Haskell values, whereas Shake serialises all 'A' values
 --   between runs. To deserialise a Shake value, we just consult Values.
 module Development.IDE.Core.Shake(
-    IdeState, shakeSessionInit, shakeExtras,
+    IdeState, shakeSessionInit, shakeExtras, shakeDb,
     ShakeExtras(..), getShakeExtras, getShakeExtrasRules,
     KnownTargets, Target(..), toKnownFiles,
     IdeRule, IdeResult,

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

@@ -27,6 +27,7 @@ import           Development.IDE.Core.Service
 import           Development.IDE.Core.Shake
 import           Development.IDE.GHC.Compat
 import           Development.IDE.Graph          (Action)
+import           Development.IDE.Graph.Database (shakeLastBuildKeys)
 import           Development.IDE.Types.Action
 import           Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv))
 import           Development.IDE.Types.Location (fromUri)
@@ -38,10 +39,11 @@ import           System.Time.Extra
 
 data TestRequest
     = BlockSeconds Seconds           -- ^ :: Null
-    | GetInterfaceFilesDir FilePath  -- ^ :: String
+    | GetInterfaceFilesDir Uri       -- ^ :: String
     | GetShakeSessionQueueCount      -- ^ :: Number
     | WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null
     | WaitForIdeRule String Uri      -- ^ :: WaitForIdeRuleResult
+    | GetLastBuildKeys               -- ^ :: [String]
     deriving Generic
     deriving anyclass (FromJSON, ToJSON)
 
@@ -70,8 +72,8 @@ testRequestHandler _ (BlockSeconds secs) = do
       toJSON secs
     liftIO $ sleep secs
     return (Right Null)
-testRequestHandler s (GetInterfaceFilesDir fp) = liftIO $ do
-    let nfp = toNormalizedFilePath fp
+testRequestHandler s (GetInterfaceFilesDir file) = liftIO $ do
+    let nfp = fromUri $ toNormalizedUri file
     sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp
     let hiPath = hiDir $ hsc_dflags $ hscEnv sess
     return $ Right (toJSON hiPath)
@@ -88,6 +90,9 @@ testRequestHandler s (WaitForIdeRule k file) = liftIO $ do
     success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp
     let res = WaitForIdeRuleResult <$> success
     return $ bimap mkResponseError toJSON res
+testRequestHandler s GetLastBuildKeys = liftIO $ do
+    keys <- shakeLastBuildKeys $ shakeDb s
+    return $ Right $ toJSON $ map show keys
 
 mkResponseError :: Text -> ResponseError
 mkResponseError msg = ResponseError InvalidRequest msg Nothing

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

@@ -20,6 +20,7 @@ module Development.IDE.Test
   , standardizeQuotes
   , flushMessages
   , waitForAction
+  , getLastBuildKeys
   ) where
 
 import           Control.Applicative.Combinators
@@ -169,13 +170,20 @@ canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePat
 diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics)
 diagnostic = LspTest.message STextDocumentPublishDiagnostics
 
-waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)
-waitForAction key TextDocumentIdentifier{_uri} = do
+callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)
+callTestPlugin cmd = do
     let cm = SCustomMethod "test"
-    waitId <- sendRequest cm (A.toJSON $ WaitForIdeRule key _uri)
+    waitId <- sendRequest cm (A.toJSON cmd)
     ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId
     return $ do
       e <- _result
       case A.fromJSON e of
         A.Error e   -> Left $ ResponseError InternalError (T.pack e) Nothing
         A.Success a -> pure a
+
+waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)
+waitForAction key TextDocumentIdentifier{_uri} =
+    callTestPlugin (WaitForIdeRule key _uri)
+
+getLastBuildKeys :: Session (Either ResponseError [T.Text])
+getLastBuildKeys = callTestPlugin GetLastBuildKeys

hls-graph/src/Development/IDE/Graph/Database.hs

@@ -8,13 +8,16 @@ module Development.IDE.Graph.Database(
     shakeRunDatabase,
     shakeRunDatabaseForKeys,
     shakeProfileDatabase,
+    shakeLastBuildKeys
     ) where
 
 import           Data.Dynamic
+import           Data.IORef
 import           Data.Maybe
-import           Development.IDE.Graph.Classes ()
+import           Development.IDE.Graph.Classes           ()
 import           Development.IDE.Graph.Internal.Action
 import           Development.IDE.Graph.Internal.Database
+import qualified Development.IDE.Graph.Internal.Ids      as Ids
 import           Development.IDE.Graph.Internal.Options
 import           Development.IDE.Graph.Internal.Profile  (writeProfile)
 import           Development.IDE.Graph.Internal.Rules
@@ -56,3 +59,10 @@ shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do
 -- | Given a 'ShakeDatabase', write an HTML profile to the given file about the latest run.
 shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO ()
 shakeProfileDatabase (ShakeDatabase _ _ s) file = writeProfile file s
+
+-- | Returns the set of keys built in the most recent step
+shakeLastBuildKeys :: ShakeDatabase -> IO [Key]
+shakeLastBuildKeys (ShakeDatabase _ _ db) = do
+    keys <- Ids.elems $ databaseValues db
+    step <- readIORef $ databaseStep db
+    return [ k | (k, Clean res) <- keys, resultBuilt res == step ]

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

@@ -27,7 +27,8 @@ module Test.Hls
     waitForBuildQueue,
     waitForTypecheck,
     waitForAction,
-    sendConfigurationChanged)
+    sendConfigurationChanged,
+    getLastBuildKeys)
 where
 
 import           Control.Applicative.Combinators
@@ -47,7 +48,7 @@ import           Development.IDE                 (IdeState, noLogging)
 import           Development.IDE.Graph           (ShakeOptions (shakeThreads))
 import           Development.IDE.Main
 import qualified Development.IDE.Main            as Ghcide
-import           Development.IDE.Plugin.Test     (TestRequest (WaitForIdeRule, WaitForShakeQueue),
+import           Development.IDE.Plugin.Test     (TestRequest (GetLastBuildKeys, WaitForIdeRule, WaitForShakeQueue),
                                                   WaitForIdeRuleResult (ideResultSuccess))
 import           Development.IDE.Types.Options
 import           GHC.IO.Handle
@@ -216,20 +217,27 @@ waitForBuildQueue = do
         -- assume a ghcide binary lacking the WaitForShakeQueue method
         _                                   -> return 0
 
-waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)
-waitForAction key TextDocumentIdentifier{_uri} = do
+callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)
+callTestPlugin cmd = do
     let cm = SCustomMethod "test"
-    waitId <- sendRequest cm (A.toJSON $ WaitForIdeRule key _uri)
+    waitId <- sendRequest cm (A.toJSON cmd)
     ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId
     return $ do
       e <- _result
       case A.fromJSON e of
         A.Error err   -> Left $ ResponseError InternalError (T.pack err) Nothing
         A.Success a -> pure a
 
+waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)
+waitForAction key TextDocumentIdentifier{_uri} =
+    callTestPlugin (WaitForIdeRule key _uri)
+
 waitForTypecheck :: TextDocumentIdentifier -> Session (Either ResponseError Bool)
 waitForTypecheck tid = fmap ideResultSuccess <$> waitForAction "typecheck" tid
 
+getLastBuildKeys :: Session (Either ResponseError [T.Text])
+getLastBuildKeys = callTestPlugin GetLastBuildKeys
+
 sendConfigurationChanged :: Value -> Session ()
 sendConfigurationChanged config =
   sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams config)