schedule a GC on file close

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

@@ -256,9 +256,9 @@ setFileModified state saved nfp = do
     ideOptions <- getIdeOptionsIO $ shakeExtras state
     doCheckParents <- optCheckParents ideOptions
     let checkParents = case doCheckParents of
-          AlwaysCheck         -> True
-          CheckOnSaveAndClose -> saved
-          _                   -> False
+          AlwaysCheck -> True
+          CheckOnSave -> saved
+          _           -> False
     VFSHandle{..} <- getIdeGlobalState state
     when (isJust setVirtualFileContents) $
         fail "setFileModified can't be called on this type of VFSHandle"

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

@@ -15,7 +15,7 @@ module Development.IDE.Core.OfInterest(
     setFilesOfInterest,
     kick, FileOfInterestStatus(..),
     OfInterestVar(..)
-    ) where
+    ,scheduleGarbageCollection) where
 
 import           Control.Concurrent.Strict
 import           Control.Monad
@@ -33,7 +33,6 @@ import           Development.IDE.Core.Shake
 import           Development.IDE.Types.Exports
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Logger
-import           System.Time.Extra                      (sleep)
 
 newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus))
 instance IsIdeGlobal OfInterestVar
@@ -42,6 +41,7 @@ instance IsIdeGlobal OfInterestVar
 ofInterestRules :: Rules ()
 ofInterestRules = do
     addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty)
+    addIdeGlobal . GarbageCollectVar =<< liftIO (newVar False)
     defineEarlyCutoff $ RuleNoDiagnostics $ \IsFileOfInterest f -> do
         alwaysRerun
         filesOfInterest <- getFilesOfInterestUntracked
@@ -55,6 +55,9 @@ ofInterestRules = do
     summarize (IsFOI (Modified False)) = BS.singleton 2
     summarize (IsFOI (Modified True))  = BS.singleton 3
 
+------------------------------------------------------------
+newtype GarbageCollectVar = GarbageCollectVar (Var Bool)
+instance IsIdeGlobal GarbageCollectVar
 
 ------------------------------------------------------------
 -- Exposed API
@@ -94,6 +97,10 @@ deleteFileOfInterest state f = do
     recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
     logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files)
 
+scheduleGarbageCollection :: IdeState -> IO ()
+scheduleGarbageCollection state = do
+    GarbageCollectVar var <- getIdeGlobalState state
+    writeVar var True
 
 -- | Typecheck all the files of interest.
 --   Could be improved
@@ -111,6 +118,8 @@ kick = do
 
     liftIO $ progressUpdate progress KickCompleted
 
-    -- if idle, perform garbage collection of dirty keys
-    liftIO $ sleep 5
-    void garbageCollectDirtyKeys
+    GarbageCollectVar var <- getIdeGlobalAction
+    garbageCollectionScheduled <- liftIO $ readVar var
+    when garbageCollectionScheduled $ do
+        void garbageCollectDirtyKeys
+        liftIO $ writeVar var False

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

@@ -148,7 +148,9 @@ import           Language.LSP.Types.Capabilities
 import           OpenTelemetry.Eventlog
 
 import           Control.Exception.Extra                hiding (bracket_)
+import           Data.Aeson                             (toJSON)
 import qualified Data.ByteString.Char8                  as BS8
+import           Data.Coerce                            (coerce)
 import           Data.Default
 import           Data.Foldable                          (toList)
 import           Data.HashSet                           (HashSet)
@@ -761,9 +763,9 @@ getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do
 --     * exports map
 garbageCollectDirtyKeys :: Action [Key]
 garbageCollectDirtyKeys = do
-    IdeOptions{optCheckParents, optMaxDirtyAge} <- getIdeOptions
+    IdeOptions{optCheckParents} <- getIdeOptions
     checkParents <- liftIO optCheckParents
-    garbageCollectDirtyKeysOlderThan optMaxDirtyAge checkParents
+    garbageCollectDirtyKeysOlderThan 0 checkParents
 
 garbageCollectDirtyKeysOlderThan :: Int -> CheckParents -> Action [Key]
 garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection "dirty GC" $ do
@@ -779,22 +781,27 @@ garbageCollectKeys label maxAge checkParents agedKeys = do
     liftIO $ atomicModifyIORef_ (dirtyKeys extras) $ \x ->
         foldl' (flip HSet.insert) x garbage
     t <- liftIO start
-    when (n>0) $ liftIO $ logDebug (logger extras) $ T.pack $
-        label <> " of " <> show n <> " keys (took " <> showDuration t <> ")"
+    when (n>0) $ liftIO $ do
+        logDebug (logger extras) $ T.pack $
+            label <> " of " <> show n <> " keys (took " <> showDuration t <> ")"
+    when (coerce $ ideTesting extras) $ liftIO $ mRunLspT (lspEnv extras) $
+        LSP.sendNotification (SCustomMethod "ghcide/GC")
+                             (toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage)
     return garbage
 
     where
+        showKey = show . Q
         removeDirtyKey st@(vmap,(!counter, keys)) (k, age)
             | age > maxAge
-            , Just kt <- fromKeyType k
+            , Just (kt,_) <- fromKeyType k
             , not(kt `HSet.member` preservedKeys checkParents)
             , (True, vmap') <- HMap.alterF (\prev -> (isJust prev, Nothing)) k vmap
             = (vmap', (counter+1, k:keys))
             | otherwise = st
 
 countRelevantKeys :: CheckParents -> [Key] -> Int
 countRelevantKeys checkParents =
-    Prelude.length . filter (maybe False (not . (`HSet.member` preservedKeys checkParents)) . fromKeyType)
+    Prelude.length . filter (maybe False (not . (`HSet.member` preservedKeys checkParents) . fst) . fromKeyType)
 
 preservedKeys :: CheckParents -> HashSet TypeRep
 preservedKeys checkParents = HSet.fromList $

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

@@ -187,7 +187,7 @@ performMeasurement logger stateRef instrumentFor = do
              -- TODO restore
              : [ kty
                 | k <- HMap.keys values
-                , Just kty <- [fromKeyType k]
+                , Just (kty,_) <- [fromKeyType k]
                 -- do GhcSessionIO last since it closes over stateRef itself
                 , kty /= typeOf GhcSession
                 , kty /= typeOf GhcSessionDeps
@@ -265,7 +265,7 @@ measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory"
             let !groupedValues =
                     [ [ (show ty, vv)
                       | ty <- groupKeys
-                      , let vv = [ v | (fromKeyType -> Just kty, ValueWithDiagnostics v _) <- HMap.toList values
+                      , let vv = [ v | (fromKeyType -> Just (kty,_), ValueWithDiagnostics v _) <- HMap.toList values
                                      , kty == ty]
                       ]
                     | groupKeys <- groups

ghcide/src/Development/IDE/LSP/Notifications.hs

@@ -14,30 +14,25 @@ module Development.IDE.LSP.Notifications
 import           Language.LSP.Types
 import qualified Language.LSP.Types                    as LSP
 
-import           Development.IDE.Core.IdeConfiguration
-import           Development.IDE.Core.Service
-import           Development.IDE.Core.Shake
-import           Development.IDE.Types.Location
-import           Development.IDE.Types.Logger
-import           Development.IDE.Types.Options
-
 import           Control.Monad.Extra
-import qualified Data.HashSet                          as S
-import qualified Data.Text                             as Text
-
 import           Control.Monad.IO.Class
 import qualified Data.HashMap.Strict                   as HM
+import qualified Data.HashSet                          as S
+import qualified Data.Text                             as Text
 import           Development.IDE.Core.FileExists       (modifyFileExists,
                                                         watchedGlobs)
 import           Development.IDE.Core.FileStore        (registerFileWatches,
                                                         resetFileStore,
                                                         setFileModified,
-                                                        setSomethingModified,
-                                                        typecheckParents)
+                                                        setSomethingModified)
+import           Development.IDE.Core.IdeConfiguration
 import           Development.IDE.Core.OfInterest
 import           Development.IDE.Core.RuleTypes        (GetClientSettings (..))
+import           Development.IDE.Core.Service
+import           Development.IDE.Core.Shake
+import           Development.IDE.Types.Location
+import           Development.IDE.Types.Logger
 import           Development.IDE.Types.Shake           (toKey)
-import           Ide.Plugin.Config                     (CheckParents (CheckOnClose))
 import           Ide.Types
 
 whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
@@ -74,10 +69,10 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers =
         \ide _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do
           whenUriFile _uri $ \file -> do
               deleteFileOfInterest ide file
-              -- Refresh all the files that depended on this
-              checkParents <- optCheckParents =<< getIdeOptionsIO (shakeExtras ide)
-              when (checkParents >= CheckOnClose) $ typecheckParents ide file
-              logDebug (ideLogger ide) $ "Closed text document: " <> getUri _uri
+              let msg = "Closed text document: " <> getUri _uri
+              scheduleGarbageCollection ide
+              setSomethingModified ide [] $ Text.unpack msg
+              logDebug (ideLogger ide) msg
 
   , mkPluginNotificationHandler LSP.SWorkspaceDidChangeWatchedFiles $
       \ide _ (DidChangeWatchedFilesParams (List fileEvents)) -> liftIO $ do

ghcide/src/Development/IDE/Main.hs

@@ -375,7 +375,7 @@ defaultMain Arguments{..} = do
                         nub $
                             typeOf GhcSession :
                             typeOf GhcSessionDeps :
-                            [kty | (fromKeyType -> Just kty) <- HashMap.keys values, kty /= typeOf GhcSessionIO] ++
+                            [kty | (fromKeyType -> Just (kty,_)) <- HashMap.keys values, kty /= typeOf GhcSessionIO] ++
                             [typeOf GhcSessionIO]
                 measureMemory logger [keys] consoleObserver valuesRef
 

ghcide/src/Development/IDE/Types/Options.hs

@@ -139,7 +139,7 @@ defaultIdeOptions session = IdeOptions
     ,optDefer = IdeDefer True
     ,optTesting = IdeTesting False
     ,optCheckProject = pure True
-    ,optCheckParents = pure CheckOnSaveAndClose
+    ,optCheckParents = pure CheckOnSave
     ,optHaddockParse = HaddockParse
     ,optModifyDynFlags = mempty
     ,optSkipProgress = defaultSkipProgress

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

@@ -35,6 +35,7 @@ import           Type.Reflection                      (SomeTypeRep (SomeTypeRep)
                                                        pattern App, pattern Con,
                                                        typeOf, typeRep,
                                                        typeRepTyCon)
+import           Unsafe.Coerce                        (unsafeCoerce)
 
 data Value v
     = Succeeded TextDocumentVersion v
@@ -75,11 +76,12 @@ fromKey (Key k)
   | Just (Q (k', f)) <- cast k = Just (k', f)
   | otherwise = Nothing
 
--- | fromKeyType (Q a) = typeOf a
-fromKeyType :: Key -> Maybe SomeTypeRep
+-- | fromKeyType (Q (k,f)) = (typeOf k, f)
+fromKeyType :: Key -> Maybe (SomeTypeRep, NormalizedFilePath)
 fromKeyType (Key k) = case typeOf k of
     App (Con tc) a | tc == typeRepTyCon (typeRep @Q)
-        -> Just $ SomeTypeRep a
+        -> case unsafeCoerce k of
+         Q (_ :: (), f) -> Just (SomeTypeRep a, f)
     _ -> Nothing
 
 toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k) => k -> Key

ghcide/test/exe/Main.hs

@@ -51,11 +51,9 @@ import           Development.IDE.Test                     (Cursor,
                                                            flushMessages,
                                                            standardizeQuotes,
                                                            waitForAction,
-                                                           garbageCollectDirtyKeys,
                                                            getStoredKeys,
                                                            waitForTypecheck,
-                                                           getFilesOfInterest,
-                                                           waitForBuildQueue)
+                                                           getFilesOfInterest, waitForGC)
 import           Development.IDE.Test.Runfiles
 import qualified Development.IDE.Types.Diagnostics        as Diagnostics
 import           Development.IDE.Types.Location
@@ -5845,83 +5843,75 @@ unitTests = do
 
 garbageCollectionTests :: TestTree
 garbageCollectionTests = testGroup "garbage collection"
-  [ testGroup "dirty keys" (sharedGCtests $ garbageCollectDirtyKeys CheckOnSaveAndClose)
-  ]
-  where
-    sharedGCtests gc =
+  [ testGroup "dirty keys"
         [ testSession' "are collected" $ \dir -> do
             liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
-            void $ generateGarbage "A" dir
-            garbage <- gc 0
+            doc <- generateGarbage "A" dir
+            closeDoc doc
+            garbage <- waitForGC
             liftIO $ assertBool "no garbage was found" $ not $ null garbage
 
         , testSession' "are deleted from the state" $ \dir -> do
             liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
-            void $ generateGarbage "A" dir
+            docA <- generateGarbage "A" dir
             keys0 <- getStoredKeys
-            garbage <- gc 0
+            closeDoc docA
+            garbage <- waitForGC
             liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage
             keys1 <- getStoredKeys
             liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0)
 
         , testSession' "are not regenerated unless needed" $ \dir -> do
             liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}"
-            void $ generateGarbage "A" dir
+            docA <- generateGarbage "A" dir
+            _docB <- generateGarbage "B" dir
 
-            reopenB <- generateGarbage "B" dir
             -- garbage collect A keys
             keysBeforeGC <- getStoredKeys
-            garbage <- gc 2
+            closeDoc docA
+            garbage <- waitForGC
             liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage
             keysAfterGC <- getStoredKeys
-            liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state" (length keysAfterGC < length keysBeforeGC)
-            ff <- getFilesOfInterest
-            liftIO $ assertBool ("something is wrong with this test - files of interest is " <> show ff) (null ff)
-
-            -- typecheck B again
-            doc <- reopenB
-            void $ waitForTypecheck doc
+            liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state"
+                (length keysAfterGC < length keysBeforeGC)
 
-            -- review the keys in store now to validate that A keys have not been regenerated
-            keysB' <- getStoredKeys
+            -- re-typecheck B and check that the keys for A have not materialized back
+            _docB <- generateGarbage "B" dir
+            keysB <- getStoredKeys
             let regeneratedKeys = Set.filter (not . isExpected) $
-                    Set.intersection (Set.fromList garbage) (Set.fromList keysB')
+                    Set.intersection (Set.fromList garbage) (Set.fromList keysB)
             liftIO $ regeneratedKeys @?= mempty
 
         , testSession' "regenerate successfully" $ \dir -> do
             liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
-            reopenA <- generateGarbage "A" dir
-            garbage <- gc 0
+            docA <- generateGarbage "A" dir
+            closeDoc docA
+            garbage <- waitForGC
             liftIO $ assertBool "no garbage was found" $ not $ null garbage
             let edit = T.unlines
                         [ "module A where"
                         , "a :: Bool"
                         , "a = ()"
                         ]
-            doc <- reopenA
+            doc <- generateGarbage "A" dir
             changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing edit]
             builds <- waitForTypecheck doc
             liftIO $ assertBool "it still builds" builds
             expectCurrentDiagnostics doc [(DsError, (2,4), "Couldn't match expected type")]
         ]
+  ]
+  where
+    isExpected k = any (`T.isPrefixOf` k) ["GhcSessionIO"]
 
-    isExpected k = any (`isPrefixOf` k) ["GhcSessionIO"]
-
-    generateGarbage :: String -> FilePath -> Session(Session TextDocumentIdentifier)
+    generateGarbage :: String -> FilePath -> Session TextDocumentIdentifier
     generateGarbage modName dir = do
         let fp = modName <> ".hs"
             body = printf "module %s where" modName
         doc <- createDoc fp "haskell" (T.pack body)
         liftIO $ writeFile (dir </> fp) body
         builds <- waitForTypecheck doc
         liftIO $ assertBool "something is wrong with this test" builds
-        closeDoc doc
-        waitForBuildQueue
-        -- dirty the garbage
-        sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
-            List [FileEvent (filePathToUri $ dir </> modName <> ".hs") FcChanged ]
-
-        return $ openDoc (modName <> ".hs") "haskell"
+        return doc
 
 findResolution_us :: Int -> IO Int
 findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution"