Skip to content

Commit c3d1fae

Browse files
pepeiborrapepeiborra
committed
getLastBuildKeys
1 parent 3c8a303 commit c3d1fae

File tree

5 files changed

+44
-13
lines changed

5 files changed

+44
-13
lines changed

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -24,7 +24,7 @@
2424
-- always stored as real Haskell values, whereas Shake serialises all 'A' values
2525
-- between runs. To deserialise a Shake value, we just consult Values.
2626
module Development.IDE.Core.Shake(
27-
IdeState, shakeSessionInit, shakeExtras,
27+
IdeState, shakeSessionInit, shakeExtras, shakeDb,
2828
ShakeExtras(..), getShakeExtras, getShakeExtrasRules,
2929
KnownTargets, Target(..), toKnownFiles,
3030
IdeRule, IdeResult,

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

Lines changed: 8 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -27,6 +27,7 @@ import Development.IDE.Core.Service
2727
import Development.IDE.Core.Shake
2828
import Development.IDE.GHC.Compat
2929
import Development.IDE.Graph (Action)
30+
import Development.IDE.Graph.Database (shakeLastBuildKeys)
3031
import Development.IDE.Types.Action
3132
import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv))
3233
import Development.IDE.Types.Location (fromUri)
@@ -38,10 +39,11 @@ import System.Time.Extra
3839

3940
data TestRequest
4041
= BlockSeconds Seconds -- ^ :: Null
41-
| GetInterfaceFilesDir FilePath -- ^ :: String
42+
| GetInterfaceFilesDir Uri -- ^ :: String
4243
| GetShakeSessionQueueCount -- ^ :: Number
4344
| WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null
4445
| WaitForIdeRule String Uri -- ^ :: WaitForIdeRuleResult
46+
| GetLastBuildKeys -- ^ :: [String]
4547
deriving Generic
4648
deriving anyclass (FromJSON, ToJSON)
4749

@@ -70,8 +72,8 @@ testRequestHandler _ (BlockSeconds secs) = do
7072
toJSON secs
7173
liftIO $ sleep secs
7274
return (Right Null)
73-
testRequestHandler s (GetInterfaceFilesDir fp) = liftIO $ do
74-
let nfp = toNormalizedFilePath fp
75+
testRequestHandler s (GetInterfaceFilesDir file) = liftIO $ do
76+
let nfp = fromUri $ toNormalizedUri file
7577
sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp
7678
let hiPath = hiDir $ hsc_dflags $ hscEnv sess
7779
return $ Right (toJSON hiPath)
@@ -88,6 +90,9 @@ testRequestHandler s (WaitForIdeRule k file) = liftIO $ do
8890
success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp
8991
let res = WaitForIdeRuleResult <$> success
9092
return $ bimap mkResponseError toJSON res
93+
testRequestHandler s GetLastBuildKeys = liftIO $ do
94+
keys <- shakeLastBuildKeys $ shakeDb s
95+
return $ Right $ toJSON $ map show keys
9196

9297
mkResponseError :: Text -> ResponseError
9398
mkResponseError msg = ResponseError InvalidRequest msg Nothing

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

Lines changed: 11 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ module Development.IDE.Test
2020
, standardizeQuotes
2121
, flushMessages
2222
, waitForAction
23+
, getLastBuildKeys
2324
) where
2425

2526
import Control.Applicative.Combinators
@@ -169,13 +170,20 @@ canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePat
169170
diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics)
170171
diagnostic = LspTest.message STextDocumentPublishDiagnostics
171172

172-
waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)
173-
waitForAction key TextDocumentIdentifier{_uri} = do
173+
callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)
174+
callTestPlugin cmd = do
174175
let cm = SCustomMethod "test"
175-
waitId <- sendRequest cm (A.toJSON $ WaitForIdeRule key _uri)
176+
waitId <- sendRequest cm (A.toJSON cmd)
176177
ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId
177178
return $ do
178179
e <- _result
179180
case A.fromJSON e of
180181
A.Error e -> Left $ ResponseError InternalError (T.pack e) Nothing
181182
A.Success a -> pure a
183+
184+
waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)
185+
waitForAction key TextDocumentIdentifier{_uri} =
186+
callTestPlugin (WaitForIdeRule key _uri)
187+
188+
getLastBuildKeys :: Session (Either ResponseError [T.Text])
189+
getLastBuildKeys = callTestPlugin GetLastBuildKeys

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

Lines changed: 11 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -8,13 +8,16 @@ module Development.IDE.Graph.Database(
88
shakeRunDatabase,
99
shakeRunDatabaseForKeys,
1010
shakeProfileDatabase,
11+
shakeLastBuildKeys
1112
) where
1213

1314
import Data.Dynamic
15+
import Data.IORef
1416
import Data.Maybe
15-
import Development.IDE.Graph.Classes ()
17+
import Development.IDE.Graph.Classes ()
1618
import Development.IDE.Graph.Internal.Action
1719
import Development.IDE.Graph.Internal.Database
20+
import qualified Development.IDE.Graph.Internal.Ids as Ids
1821
import Development.IDE.Graph.Internal.Options
1922
import Development.IDE.Graph.Internal.Profile (writeProfile)
2023
import Development.IDE.Graph.Internal.Rules
@@ -56,3 +59,10 @@ shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do
5659
-- | Given a 'ShakeDatabase', write an HTML profile to the given file about the latest run.
5760
shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO ()
5861
shakeProfileDatabase (ShakeDatabase _ _ s) file = writeProfile file s
62+
63+
-- | Returns the set of keys built in the most recent step
64+
shakeLastBuildKeys :: ShakeDatabase -> IO [Key]
65+
shakeLastBuildKeys (ShakeDatabase _ _ db) = do
66+
keys <- Ids.elems $ databaseValues db
67+
step <- readIORef $ databaseStep db
68+
return [ k | (k, Clean res) <- keys, resultBuilt res == step ]

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

Lines changed: 13 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -27,7 +27,8 @@ module Test.Hls
2727
waitForBuildQueue,
2828
waitForTypecheck,
2929
waitForAction,
30-
sendConfigurationChanged)
30+
sendConfigurationChanged,
31+
getLastBuildKeys)
3132
where
3233

3334
import Control.Applicative.Combinators
@@ -47,7 +48,7 @@ import Development.IDE (IdeState, noLogging)
4748
import Development.IDE.Graph (ShakeOptions (shakeThreads))
4849
import Development.IDE.Main
4950
import qualified Development.IDE.Main as Ghcide
50-
import Development.IDE.Plugin.Test (TestRequest (WaitForIdeRule, WaitForShakeQueue),
51+
import Development.IDE.Plugin.Test (TestRequest (GetLastBuildKeys, WaitForIdeRule, WaitForShakeQueue),
5152
WaitForIdeRuleResult (ideResultSuccess))
5253
import Development.IDE.Types.Options
5354
import GHC.IO.Handle
@@ -216,20 +217,27 @@ waitForBuildQueue = do
216217
-- assume a ghcide binary lacking the WaitForShakeQueue method
217218
_ -> return 0
218219

219-
waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)
220-
waitForAction key TextDocumentIdentifier{_uri} = do
220+
callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)
221+
callTestPlugin cmd = do
221222
let cm = SCustomMethod "test"
222-
waitId <- sendRequest cm (A.toJSON $ WaitForIdeRule key _uri)
223+
waitId <- sendRequest cm (A.toJSON cmd)
223224
ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId
224225
return $ do
225226
e <- _result
226227
case A.fromJSON e of
227228
A.Error err -> Left $ ResponseError InternalError (T.pack err) Nothing
228229
A.Success a -> pure a
229230

231+
waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)
232+
waitForAction key TextDocumentIdentifier{_uri} =
233+
callTestPlugin (WaitForIdeRule key _uri)
234+
230235
waitForTypecheck :: TextDocumentIdentifier -> Session (Either ResponseError Bool)
231236
waitForTypecheck tid = fmap ideResultSuccess <$> waitForAction "typecheck" tid
232237

238+
getLastBuildKeys :: Session (Either ResponseError [T.Text])
239+
getLastBuildKeys = callTestPlugin GetLastBuildKeys
240+
233241
sendConfigurationChanged :: Value -> Session ()
234242
sendConfigurationChanged config =
235243
sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams config)

0 commit comments

Comments
 (0)