Skip to content

Commit 32de4f0

Browse files
pepeiborrapepeiborra
committed
garbage collection tests
1 parent 5c01795 commit 32de4f0

File tree

3 files changed

+158
-28
lines changed

3 files changed

+158
-28
lines changed

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

Lines changed: 25 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -11,28 +11,31 @@ module Development.IDE.Plugin.Test
1111
, blockCommandId
1212
) where
1313

14-
import Control.Concurrent (threadDelay)
14+
import Control.Concurrent (threadDelay)
15+
import Control.Concurrent.Extra (readVar)
1516
import Control.Monad
1617
import Control.Monad.IO.Class
1718
import Control.Monad.STM
1819
import Data.Aeson
1920
import Data.Aeson.Types
2021
import Data.Bifunctor
21-
import Data.CaseInsensitive (CI, original)
22-
import Data.Maybe (isJust)
22+
import Data.CaseInsensitive (CI, original)
23+
import qualified Data.HashMap.Strict as HM
24+
import Data.Maybe (isJust)
2325
import Data.String
24-
import Data.Text (Text, pack)
26+
import Data.Text (Text, pack)
27+
import Development.IDE.Core.OfInterest (getFilesOfInterest)
2528
import Development.IDE.Core.RuleTypes
2629
import Development.IDE.Core.Service
2730
import Development.IDE.Core.Shake
2831
import Development.IDE.GHC.Compat
29-
import Development.IDE.Graph (Action)
32+
import Development.IDE.Graph (Action)
3033
import Development.IDE.Types.Action
31-
import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv))
32-
import Development.IDE.Types.Location (fromUri)
33-
import GHC.Generics (Generic)
34+
import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv))
35+
import Development.IDE.Types.Location (fromUri)
36+
import GHC.Generics (Generic)
3437
import Ide.Types
35-
import qualified Language.LSP.Server as LSP
38+
import qualified Language.LSP.Server as LSP
3639
import Language.LSP.Types
3740
import System.Time.Extra
3841

@@ -44,6 +47,9 @@ data TestRequest
4447
| WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null
4548
| WaitForIdeRule String Uri -- ^ :: WaitForIdeRuleResult
4649
| GarbageCollectDirtyKeys Age -- ^ :: [String] (list of keys collected)
50+
| GarbageCollectNotVisitedKeys Age -- ^ :: [String]
51+
| GetStoredKeys -- ^ :: [String] (list of keys in store)
52+
| GetFilesOfInterest -- ^ :: [FilePath]
4753
deriving Generic
4854
deriving anyclass (FromJSON, ToJSON)
4955

@@ -91,8 +97,17 @@ testRequestHandler s (WaitForIdeRule k file) = liftIO $ do
9197
let res = WaitForIdeRuleResult <$> success
9298
return $ bimap mkResponseError toJSON res
9399
testRequestHandler s (GarbageCollectDirtyKeys age) = do
94-
res <- liftIO $ runAction "garbage collect" s $ garbageCollectDirtyKeysOlderThan age
100+
res <- liftIO $ runAction "garbage collect dirty" s $ garbageCollectDirtyKeysOlderThan age
95101
return $ Right $ toJSON $ map show res
102+
testRequestHandler s (GarbageCollectNotVisitedKeys age) = do
103+
res <- liftIO $ runAction "garbage collect not visited" s $ garbageCollectKeysNotVisitedFor age
104+
return $ Right $ toJSON $ map show res
105+
testRequestHandler s GetStoredKeys = do
106+
keys <- liftIO $ HM.keys <$> readVar (state $ shakeExtras s)
107+
return $ Right $ toJSON $ map show keys
108+
testRequestHandler s GetFilesOfInterest = do
109+
ff <- liftIO $ getFilesOfInterest s
110+
return $ Right $ toJSON $ map fromNormalizedFilePath $ HM.keys ff
96111

97112
mkResponseError :: Text -> ResponseError
98113
mkResponseError msg = ResponseError InvalidRequest msg Nothing

‎ghcide/test/exe/Main.hs

Lines changed: 94 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -50,7 +50,13 @@ import Development.IDE.Test (Cursor,
5050
expectNoMoreDiagnostics,
5151
flushMessages,
5252
standardizeQuotes,
53-
waitForAction)
53+
waitForAction,
54+
garbageCollectDirtyKeys,
55+
getStoredKeys,
56+
waitForTypecheck,
57+
getFilesOfInterest,
58+
waitForBuildQueue,
59+
garbageCollectNotVisitedKeys)
5460
import Development.IDE.Test.Runfiles
5561
import qualified Development.IDE.Types.Diagnostics as Diagnostics
5662
import Development.IDE.Types.Location
@@ -172,6 +178,7 @@ main = do
172178
, clientSettingsTest
173179
, codeActionHelperFunctionTests
174180
, referenceTests
181+
, garbageCollectionTests
175182
]
176183

177184
initializeResponseTests :: TestTree
@@ -718,7 +725,7 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r
718725
-- Now we edit the document and wait for the given key (if any)
719726
changeDoc doc [edit]
720727
whenJust mbKey $ \(key, expectedResult) -> do
721-
Right WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc
728+
WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc
722729
liftIO $ ideResultSuccess @?= expectedResult
723730

724731
-- The 2nd edit cancels the active session and unbreaks the file
@@ -732,7 +739,7 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r
732739
runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s
733740

734741
typeCheck doc = do
735-
Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
742+
WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
736743
liftIO $ assertBool "The file should typecheck" ideResultSuccess
737744
-- wait for the debouncer to publish diagnostics if the rule runs
738745
liftIO $ sleep 0.2
@@ -5035,7 +5042,7 @@ retryFailedCradle = testSession' "retry failed" $ \dir -> do
50355042
liftIO $ writeFile hiePath hieContents
50365043
let aPath = dir </> "A.hs"
50375044
doc <- createDoc aPath "haskell" "main = return ()"
5038-
Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
5045+
WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
50395046
liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess
50405047

50415048
-- Fix the cradle and typecheck again
@@ -5044,7 +5051,7 @@ retryFailedCradle = testSession' "retry failed" $ \dir -> do
50445051
sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
50455052
List [FileEvent (filePathToUri $ dir </> "hie.yaml") FcChanged ]
50465053

5047-
Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
5054+
WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
50485055
liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess
50495056

50505057

@@ -5123,11 +5130,11 @@ simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraF
51235130
bPath = dir </> "b/B.hs"
51245131
aSource <- liftIO $ readFileUtf8 aPath
51255132
adoc <- createDoc aPath "haskell" aSource
5126-
Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc
5133+
WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc
51275134
liftIO $ assertBool "A should typecheck" ideResultSuccess
51285135
bSource <- liftIO $ readFileUtf8 bPath
51295136
bdoc <- createDoc bPath "haskell" bSource
5130-
Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc
5137+
WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc
51315138
liftIO $ assertBool "B should typecheck" ideResultSuccess
51325139
locs <- getDefinitions bdoc (Position 2 7)
51335140
let fooL = mkL (adoc ^. L.uri) 2 0 2 3
@@ -5837,6 +5844,86 @@ unitTests = do
58375844
, Progress.tests
58385845
]
58395846

5847+
garbageCollectionTests :: TestTree
5848+
garbageCollectionTests = testGroup "garbage collection"
5849+
[ testGroup "dirty keys" (sharedGCtests garbageCollectDirtyKeys)
5850+
, testGroup "unvisited keys" (sharedGCtests garbageCollectNotVisitedKeys)
5851+
]
5852+
where
5853+
sharedGCtests gc =
5854+
[ testSession' "are collected" $ \dir -> do
5855+
liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
5856+
void $ generateGarbage "A" dir
5857+
garbage <- gc 0
5858+
liftIO $ assertBool "no garbage was found" $ not $ null garbage
5859+
5860+
, testSession' "are deleted from the state" $ \dir -> do
5861+
liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
5862+
void $ generateGarbage "A" dir
5863+
keys0 <- getStoredKeys
5864+
garbage <- gc 0
5865+
liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage
5866+
keys1 <- getStoredKeys
5867+
liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0)
5868+
5869+
, testSession' "are not regenerated unless needed" $ \dir -> do
5870+
liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}"
5871+
void $ generateGarbage "A" dir
5872+
5873+
keysA <- getStoredKeys
5874+
5875+
reopenB <- generateGarbage "B" dir
5876+
-- garbage collect A keys
5877+
garbage <- gc 1
5878+
liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage
5879+
keysB <- getStoredKeys
5880+
liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state" (length keysB < length keysA)
5881+
ff <- getFilesOfInterest
5882+
liftIO $ assertBool ("something is wrong with this test - files of interest is " <> show ff) (null ff)
5883+
5884+
-- typecheck B again
5885+
_ <- reopenB
5886+
5887+
-- review the keys in store now to validate that A keys have not been regenerated
5888+
keysB' <- getStoredKeys
5889+
let regeneratedKeys = Set.filter (not . isExpected) $
5890+
Set.intersection (Set.fromList garbage) (Set.fromList keysB')
5891+
liftIO $ regeneratedKeys @?= mempty
5892+
5893+
, testSession' "regenerate successfully" $ \dir -> do
5894+
liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
5895+
reopenA <- generateGarbage "A" dir
5896+
garbage <- gc 0
5897+
liftIO $ assertBool "no garbage was found" $ not $ null garbage
5898+
let edit = T.unlines
5899+
[ "module A where"
5900+
, "a :: Bool"
5901+
, "a = ()"
5902+
]
5903+
doc <- reopenA
5904+
changeDoc doc ([TextDocumentContentChangeEvent Nothing Nothing edit])
5905+
builds <- waitForTypecheck doc
5906+
liftIO $ assertBool "it still builds" builds
5907+
expectCurrentDiagnostics doc ([(DsError, (2,4), "Couldn't match expected type")])
5908+
]
5909+
5910+
isExpected k = any (`isPrefixOf` k) ["GhcSessionIO"]
5911+
5912+
generateGarbage :: String -> FilePath -> Session(Session TextDocumentIdentifier)
5913+
generateGarbage modName dir = do
5914+
let fp = modName <> ".hs"
5915+
body = printf "module %s where" modName
5916+
doc <- createDoc fp "haskell" (T.pack body)
5917+
liftIO $ writeFile (dir </> fp) body
5918+
builds <- waitForTypecheck doc
5919+
liftIO $ assertBool "something is wrong with this test" builds
5920+
closeDoc doc
5921+
waitForBuildQueue
5922+
-- dirty the garbage
5923+
sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
5924+
List [FileEvent (filePathToUri $ dir </> modName <> ".hs") FcChanged ]
5925+
return $ openDoc (modName <> ".hs") "haskell"
5926+
58405927
findResolution_us :: Int -> IO Int
58415928
findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution"
58425929
findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do

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

Lines changed: 39 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,12 @@ module Development.IDE.Test
2020
, standardizeQuotes
2121
, flushMessages
2222
, waitForAction
23+
, garbageCollectDirtyKeys
24+
, getFilesOfInterest
25+
, waitForTypecheck
26+
, waitForBuildQueue
27+
, getStoredKeys
28+
, garbageCollectNotVisitedKeys
2329
) where
2430

2531
import Control.Applicative.Combinators
@@ -32,7 +38,8 @@ import qualified Data.Map.Strict as Map
3238
import Data.Maybe (fromJust)
3339
import qualified Data.Text as T
3440
import Development.IDE.Plugin.Test (TestRequest (..),
35-
WaitForIdeRuleResult)
41+
WaitForIdeRuleResult,
42+
ideResultSuccess)
3643
import Development.IDE.Test.Diagnostic
3744
import Language.LSP.Test hiding (message)
3845
import qualified Language.LSP.Test as LspTest
@@ -169,13 +176,34 @@ canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePat
169176
diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics)
170177
diagnostic = LspTest.message STextDocumentPublishDiagnostics
171178

172-
waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)
173-
waitForAction key TextDocumentIdentifier{_uri} = do
174-
let cm = SCustomMethod "test"
175-
waitId <- sendRequest cm (A.toJSON $ WaitForIdeRule key _uri)
176-
ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId
177-
return $ do
178-
e <- _result
179-
case A.fromJSON e of
180-
A.Error e -> Left $ ResponseError InternalError (T.pack e) Nothing
181-
A.Success a -> pure a
179+
callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b
180+
callTestPlugin cmd = do
181+
let m = SCustomMethod "test"
182+
waitId <- sendRequest m (A.toJSON cmd)
183+
ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId m waitId
184+
return $ case _result of
185+
Left (ResponseError t err _) -> error $ show t <> ": " <> T.unpack err
186+
Right json -> case A.fromJSON json of
187+
A.Success a -> a
188+
A.Error e -> error e
189+
190+
waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResult
191+
waitForAction key TextDocumentIdentifier{_uri} = callTestPlugin (WaitForIdeRule key _uri)
192+
193+
garbageCollectDirtyKeys :: Int -> Session [String]
194+
garbageCollectDirtyKeys age = callTestPlugin (GarbageCollectDirtyKeys age)
195+
196+
garbageCollectNotVisitedKeys :: Int -> Session [String]
197+
garbageCollectNotVisitedKeys age = callTestPlugin (GarbageCollectNotVisitedKeys age)
198+
199+
getStoredKeys :: Session [String]
200+
getStoredKeys = callTestPlugin GetStoredKeys
201+
202+
waitForTypecheck :: TextDocumentIdentifier -> Session Bool
203+
waitForTypecheck tid = ideResultSuccess <$> waitForAction "typecheck" tid
204+
205+
waitForBuildQueue :: Session ()
206+
waitForBuildQueue = callTestPlugin WaitForShakeQueue
207+
208+
getFilesOfInterest :: Session [FilePath]
209+
getFilesOfInterest = callTestPlugin GetFilesOfInterest

0 commit comments

Comments
 (0)