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