diff --git a/ghcide/.hlint.yaml b/ghcide/.hlint.yaml index 725604f7df..01f035184a 100644 --- a/ghcide/.hlint.yaml +++ b/ghcide/.hlint.yaml @@ -133,7 +133,7 @@ # Things that are unsafe in Haskell base library - {name: unsafeInterleaveIO, within: [Development.IDE.LSP.LanguageServer]} - {name: unsafeDupablePerformIO, within: []} - - {name: unsafeCoerce, within: [Ide.Plugin.Eval.Code]} + - {name: unsafeCoerce, within: [Ide.Plugin.Eval.Code, Development.IDE.Types.Shake]} # Things that are a bit dangerous in the GHC API - {name: nameModule, within: []} diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 0ff9eb5adc..ccd1b0aa7d 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -77,7 +77,7 @@ library rope-utf16-splay, safe, safe-exceptions, - hls-graph ^>= 1.5, + hls-graph ^>= 1.5.1, sorted-list, sqlite-simple, stm, diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 2cc9d1c7f1..fe52b65975 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/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" diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 880d9f456d..bc53fba870 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/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 @@ -41,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 @@ -54,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 @@ -93,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 @@ -109,3 +117,9 @@ kick = do void $ liftIO $ modifyVar' exportsMap (exportsMap' <>) liftIO $ progressUpdate progress KickCompleted + + GarbageCollectVar var <- getIdeGlobalAction + garbageCollectionScheduled <- liftIO $ readVar var + when garbageCollectionScheduled $ do + void garbageCollectDirtyKeys + liftIO $ writeVar var False diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 60b7c34fe3..5670cb540b 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -53,7 +53,6 @@ module Development.IDE.Core.Shake( GlobalIdeOptions(..), HLS.getClientConfig, getPluginConfig, - garbageCollect, knownTargets, setPriority, ideLogger, @@ -74,7 +73,9 @@ module Development.IDE.Core.Shake( HieDb, HieDbWriter(..), VFSHandle(..), - addPersistentRule + addPersistentRule, + garbageCollectDirtyKeys, + garbageCollectDirtyKeysOlderThan, ) where import Control.Concurrent.Async @@ -94,7 +95,6 @@ import Data.List.Extra (foldl', partition, import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe -import qualified Data.Set as Set import qualified Data.SortedList as SL import qualified Data.Text as T import Data.Time @@ -118,7 +118,11 @@ import Development.IDE.GHC.Compat (NameCache, import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue) import qualified Development.IDE.Graph as Shake -import Development.IDE.Graph.Database +import Development.IDE.Graph.Database (ShakeDatabase, + shakeGetBuildStep, + shakeOpenDatabase, + shakeProfileDatabase, + shakeRunDatabaseForKeys) import Development.IDE.Graph.Rule import Development.IDE.Types.Action import Development.IDE.Types.Diagnostics @@ -144,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) @@ -153,6 +159,7 @@ import Data.IORef.Extra (atomicModifyIORef'_, atomicModifyIORef_) import Data.String (fromString) import Data.Text (pack) +import Debug.Trace.Flags (userTracingEnabled) import qualified Development.IDE.Types.Exports as ExportsMap import HieDb.Types import Ide.Plugin.Config @@ -327,10 +334,10 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do MaybeT $ pure $ (,del,ver) <$> fromDynamic dv case mv of Nothing -> do - void $ modifyVar' state $ HMap.alter (alterValue $ Failed True) (file,Key k) + void $ modifyVar' state $ HMap.alter (alterValue $ Failed True) (toKey k file) return Nothing Just (v,del,ver) -> do - void $ modifyVar' state $ HMap.alter (alterValue $ Stale (Just del) ver (toDyn v)) (file,Key k) + void $ modifyVar' state $ HMap.alter (alterValue $ Stale (Just del) ver (toDyn v)) (toKey k file) return $ Just (v,addDelta del $ mappingForVersion allMappings file ver) -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics @@ -341,7 +348,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do -- Something already succeeded before, leave it alone _ -> old - case HMap.lookup (file,Key k) hm of + case HMap.lookup (toKey k file) hm of Nothing -> readPersistent Just (ValueWithDiagnostics v _) -> case v of Succeeded ver (fromDynamic -> Just v) -> pure (Just (v, mappingForVersion allMappings file ver)) @@ -356,12 +363,6 @@ lastValue key file = do s <- getShakeExtras liftIO $ lastValueIO s key file -valueVersion :: Value v -> Maybe TextDocumentVersion -valueVersion = \case - Succeeded ver _ -> Just ver - Stale _ ver _ -> Just ver - Failed _ -> Nothing - mappingForVersion :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping)) -> NormalizedFilePath @@ -419,7 +420,7 @@ setValues :: IdeRule k v -> Vector FileDiagnostic -> IO () setValues state key file val diags = - void $ modifyVar' state $ HMap.insert (file, Key key) (ValueWithDiagnostics (fmap toDyn val) diags) + void $ modifyVar' state $ HMap.insert (toKey key file) (ValueWithDiagnostics (fmap toDyn val) diags) -- | Delete the value stored for a given ide build key @@ -430,7 +431,7 @@ deleteValue -> NormalizedFilePath -> IO () deleteValue ShakeExtras{dirtyKeys, state} key file = do - void $ modifyVar' state $ HMap.delete (file, Key key) + void $ modifyVar' state $ HMap.delete (toKey key file) atomicModifyIORef_ dirtyKeys $ HSet.insert (toKey key file) recordDirtyKeys @@ -454,7 +455,7 @@ getValues :: IO (Maybe (Value v, Vector FileDiagnostic)) getValues state key file = do vs <- readVar state - case HMap.lookup (file, Key key) vs of + case HMap.lookup (toKey key file) vs of Nothing -> pure Nothing Just (ValueWithDiagnostics v diagsV) -> do let r = fmap (fromJust . fromDynamic @v) v @@ -543,10 +544,31 @@ shakeOpen lspEnv defaultConfig logger debouncer { optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled , optProgressStyle } <- getIdeOptionsIO shakeExtras - startTelemetry otProfilingEnabled logger $ state shakeExtras + + void $ startTelemetry shakeDb shakeExtras + startProfilingTelemetry otProfilingEnabled logger $ state shakeExtras return ideState +startTelemetry :: ShakeDatabase -> ShakeExtras -> IO (Async ()) +startTelemetry db extras@ShakeExtras{..} + | userTracingEnabled = do + countKeys <- mkValueObserver "cached keys count" + countDirty <- mkValueObserver "dirty keys count" + countBuilds <- mkValueObserver "builds count" + IdeOptions{optCheckParents} <- getIdeOptionsIO extras + checkParents <- optCheckParents + regularly 1 $ do + readVar state >>= observe countKeys . countRelevantKeys checkParents . HMap.keys + readIORef dirtyKeys >>= observe countDirty . countRelevantKeys checkParents . HSet.toList + shakeGetBuildStep db >>= observe countBuilds + + | otherwise = async (pure ()) + where + regularly :: Seconds -> IO () -> IO (Async ()) + regularly delay act = async $ forever (act >> sleep delay) + + -- | Must be called in the 'Initialized' handler and only once shakeSessionInit :: IdeState -> IO () shakeSessionInit IdeState{..} = do @@ -733,20 +755,73 @@ getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do val <- readVar hiddenDiagnostics return $ getAllDiagnostics val --- | Clear the results for all files that do not match the given predicate. -garbageCollect :: (NormalizedFilePath -> Bool) -> Action () -garbageCollect keep = do - ShakeExtras{state, diagnostics,hiddenDiagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras - liftIO $ - do newState <- modifyVar' state $ HMap.filterWithKey (\(file, _) _ -> keep file) - void $ modifyVar' diagnostics $ filterDiagnostics keep - void $ modifyVar' hiddenDiagnostics $ filterDiagnostics keep - void $ modifyVar' publishedDiagnostics $ HMap.filterWithKey (\uri _ -> keep (fromUri uri)) - let versionsForFile = - HMap.fromListWith Set.union $ - mapMaybe (\((file, _key), ValueWithDiagnostics v _) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $ - HMap.toList newState - void $ modifyVar' positionMapping $ filterVersionMap versionsForFile +-- | Find and release old keys from the state Hashmap +-- For the record, there are other state sources that this process does not release: +-- * diagnostics store (normal, hidden and published) +-- * position mapping store +-- * indexing queue +-- * exports map +garbageCollectDirtyKeys :: Action [Key] +garbageCollectDirtyKeys = do + IdeOptions{optCheckParents} <- getIdeOptions + checkParents <- liftIO optCheckParents + garbageCollectDirtyKeysOlderThan 0 checkParents + +garbageCollectDirtyKeysOlderThan :: Int -> CheckParents -> Action [Key] +garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection "dirty GC" $ do + dirtySet <- getDirtySet + garbageCollectKeys "dirty GC" maxAge checkParents dirtySet + +garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key] +garbageCollectKeys label maxAge checkParents agedKeys = do + start <- liftIO offsetTime + extras <- getShakeExtras + (n::Int, garbage) <- liftIO $ modifyVar (state extras) $ \vmap -> + evaluate $ foldl' removeDirtyKey (vmap, (0,[])) agedKeys + liftIO $ atomicModifyIORef_ (dirtyKeys extras) $ \x -> + foldl' (flip HSet.insert) x garbage + t <- liftIO start + 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 + , 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) . fst) . fromKeyType) + +preservedKeys :: CheckParents -> HashSet TypeRep +preservedKeys checkParents = HSet.fromList $ + -- always preserved + [ typeOf GetFileExists + , typeOf GetModificationTime + , typeOf IsFileOfInterest + , typeOf GhcSessionIO + , typeOf GetClientSettings + , typeOf AddWatchedFile + , typeOf GetKnownTargets + ] + ++ concat + -- preserved if CheckParents is enabled since we need to rebuild the ModuleGraph + [ [ typeOf GetModSummary + , typeOf GetModSummaryWithoutTimestamps + , typeOf GetLocatedImports + ] + | checkParents /= NeverCheck + ] -- | Define a new Rule without early cutoff define @@ -921,8 +996,8 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do v <- liftIO $ getValues state key file case v of -- No changes in the dependencies and we have - -- an existing result. - Just (v, diags) -> do + -- an existing successful result. + Just (v@Succeeded{}, diags) -> do when doDiagnostics $ updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) $ Vector.toList diags return $ Just $ RunResult ChangedNothing old $ A v @@ -1128,20 +1203,6 @@ getUriDiagnostics uri ds = maybe [] getDiagnosticsFromStore $ HMap.lookup uri ds -filterDiagnostics :: - (NormalizedFilePath -> Bool) -> - DiagnosticStore -> - DiagnosticStore -filterDiagnostics keep = - HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri) - -filterVersionMap - :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion) - -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a) - -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a) -filterVersionMap = - HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep - updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO () updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do modifyVar_ positionMapping $ \allMappings -> do diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index 0c24c8996c..d81c90d883 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -1,15 +1,18 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NoApplicativeDo #-} +{-# HLINT ignore #-} module Development.IDE.Core.Tracing ( otTracedHandler , otTracedAction - , startTelemetry + , startProfilingTelemetry , measureMemory , getInstrumentCached , otTracedProvider , otSetUri + , otTracedGarbageCollection , withTrace - ,withEventTrace) + , withEventTrace + ) where import Control.Concurrent.Async (Async, async) @@ -32,6 +35,7 @@ import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef) import Data.String (IsString (fromString)) import Data.Text.Encoding (encodeUtf8) +import Data.Typeable (TypeRep, typeOf) import Debug.Trace.Flags (userTracingEnabled) import Development.IDE.Core.RuleTypes (GhcSession (GhcSession), GhcSessionDeps (GhcSessionDeps), @@ -40,9 +44,9 @@ import Development.IDE.Graph (Action) import Development.IDE.Graph.Rule import Development.IDE.Types.Location (Uri (..)) import Development.IDE.Types.Logger (Logger, logDebug, logInfo) -import Development.IDE.Types.Shake (Key (..), Value, +import Development.IDE.Types.Shake (Value, ValueWithDiagnostics (..), - Values) + Values, fromKeyType) import Foreign.Storable (Storable (sizeOf)) import HeapSize (recursiveSize, runHeapsize) import Ide.PluginUtils (installSigUsr1Handler) @@ -50,12 +54,21 @@ import Ide.Types (PluginId (..)) import Language.LSP.Types (NormalizedFilePath, fromNormalizedFilePath) import Numeric.Natural (Natural) -import OpenTelemetry.Eventlog (Instrument, SpanInFlight (..), - Synchronicity (Asynchronous), - addEvent, beginSpan, endSpan, +import OpenTelemetry.Eventlog (SpanInFlight (..), addEvent, + beginSpan, endSpan, mkValueObserver, observe, setTag, withSpan, withSpan_) +#if MIN_VERSION_ghc(8,8,0) +otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a +otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => ByteString -> f [a] -> f [a] +withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> ByteString -> m ()) -> m a) -> m a +#else +otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a +otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => String -> f [a] -> f [a] +withEventTrace :: (MonadMask m, MonadIO m) => String -> ((String -> ByteString -> m ()) -> m a) -> m a +#endif + withTrace :: (MonadMask m, MonadIO m) => String -> ((String -> String -> m ()) -> m a) -> m a withTrace name act @@ -65,11 +78,6 @@ withTrace name act act setSpan' | otherwise = act (\_ _ -> pure ()) -#if MIN_VERSION_ghc(8,8,0) -withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> ByteString -> m ()) -> m a) -> m a -#else -withEventTrace :: (MonadMask m, MonadIO m) => String -> ((String -> ByteString -> m ()) -> m a) -> m a -#endif withEventTrace name act | userTracingEnabled = withSpan (fromString name) $ \sp -> do @@ -127,11 +135,19 @@ otTracedAction key file mode result act (const act) | otherwise = act -#if MIN_VERSION_ghc(8,8,0) -otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a -#else -otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a -#endif +otTracedGarbageCollection label act + | userTracingEnabled = fst <$> + generalBracket + (beginSpan label) + (\sp ec -> do + case ec of + ExitCaseAbort -> setTag sp "aborted" "1" + ExitCaseException e -> setTag sp "exception" (pack $ show e) + ExitCaseSuccess res -> setTag sp "keys" (pack $ unlines $ map show res) + endSpan sp) + (const act) + | otherwise = act + otTracedProvider (PluginId pluginName) provider act | userTracingEnabled = do runInIO <- askRunInIO @@ -140,17 +156,17 @@ otTracedProvider (PluginId pluginName) provider act runInIO act | otherwise = act -startTelemetry :: Bool -> Logger -> Var Values -> IO () -startTelemetry allTheTime logger stateRef = do + +startProfilingTelemetry :: Bool -> Logger -> Var Values -> IO () +startProfilingTelemetry allTheTime logger stateRef = do instrumentFor <- getInstrumentCached - mapCountInstrument <- mkValueObserver "values map count" installSigUsr1Handler $ do logInfo logger "SIGUSR1 received: performing memory measurement" - performMeasurement logger stateRef instrumentFor mapCountInstrument + performMeasurement logger stateRef instrumentFor when allTheTime $ void $ regularly (1 * seconds) $ - performMeasurement logger stateRef instrumentFor mapCountInstrument + performMeasurement logger stateRef instrumentFor where seconds = 1000000 @@ -161,21 +177,23 @@ startTelemetry allTheTime logger stateRef = do performMeasurement :: Logger -> Var Values -> - (Maybe Key -> IO OurValueObserver) -> - Instrument 'Asynchronous a m' -> + (Maybe String -> IO OurValueObserver) -> IO () -performMeasurement logger stateRef instrumentFor mapCountInstrument = do - withSpan_ "Measure length" $ readVar stateRef >>= observe mapCountInstrument . length +performMeasurement logger stateRef instrumentFor = do values <- readVar stateRef - let keys = Key GhcSession - : Key GhcSessionDeps - : [ k | (_,k) <- HMap.keys values - -- do GhcSessionIO last since it closes over stateRef itself - , k /= Key GhcSession - , k /= Key GhcSessionDeps - , k /= Key GhcSessionIO - ] ++ [Key GhcSessionIO] + let keys = typeOf GhcSession + : typeOf GhcSessionDeps + -- TODO restore + : [ kty + | k <- HMap.keys values + , Just (kty,_) <- [fromKeyType k] + -- do GhcSessionIO last since it closes over stateRef itself + , kty /= typeOf GhcSession + , kty /= typeOf GhcSessionDeps + , kty /= typeOf GhcSessionIO + ] + ++ [typeOf GhcSessionIO] groupedForSharing <- evaluate (keys `using` seqList r0) measureMemory logger [groupedForSharing] instrumentFor stateRef `catch` \(e::SomeException) -> @@ -184,7 +202,7 @@ performMeasurement logger stateRef instrumentFor mapCountInstrument = do type OurValueObserver = Int -> IO () -getInstrumentCached :: IO (Maybe Key -> IO OurValueObserver) +getInstrumentCached :: IO (Maybe String -> IO OurValueObserver) getInstrumentCached = do instrumentMap <- newVar HMap.empty mapBytesInstrument <- mkValueObserver "value map size_bytes" @@ -206,8 +224,8 @@ whenNothing act mb = mb >>= f measureMemory :: Logger - -> [[Key]] -- ^ Grouping of keys for the sharing-aware analysis - -> (Maybe Key -> IO OurValueObserver) + -> [[TypeRep]] -- ^ Grouping of keys for the sharing-aware analysis + -> (Maybe String -> IO OurValueObserver) -> Var Values -> IO () measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" $ do @@ -222,7 +240,7 @@ measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" repeatUntilJust 3 $ do -- logDebug logger (fromString $ show $ map fst groupedValues) runHeapsize 25000000 $ - forM_ groupedValues $ \(k,v) -> withSpan ("Measure " <> (fromString $ show k)) $ \sp -> do + forM_ groupedValues $ \(k,v) -> withSpan ("Measure " <> fromString k) $ \sp -> do acc <- liftIO $ newIORef 0 observe <- liftIO $ instrumentFor $ Just k mapM_ (recursiveSize >=> \x -> liftIO (modifyIORef' acc (+ x))) v @@ -242,12 +260,13 @@ measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" logInfo logger "Memory profiling could not be completed: increase the size of your nursery (+RTS -Ax) and try again" where - groupValues :: Values -> [ [(Key, [Value Dynamic])] ] + groupValues :: Values -> [ [(String, [Value Dynamic])] ] groupValues values = let !groupedValues = - [ [ (k, vv) - | k <- groupKeys - , let vv = [ v | ((_,k'), ValueWithDiagnostics v _) <- HMap.toList values , k == k'] + [ [ (show ty, vv) + | ty <- groupKeys + , let vv = [ v | (fromKeyType -> Just (kty,_), ValueWithDiagnostics v _) <- HMap.toList values + , kty == ty] ] | groupKeys <- groups ] diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index b2901bf32c..0c7ba6236e 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 5f1defb027..cb084ef11f 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -29,6 +29,7 @@ import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.IO as T import Data.Text.Lazy.Encoding (decodeUtf8) import qualified Data.Text.Lazy.IO as LT +import Data.Typeable (typeOf) import Data.Word (Word16) import Development.IDE (Action, GhcVersion (..), Priority (Debug), Rules, @@ -79,7 +80,7 @@ import Development.IDE.Types.Options (IdeGhcSession, defaultIdeOptions, optModifyDynFlags, optTesting) -import Development.IDE.Types.Shake (Key (Key)) +import Development.IDE.Types.Shake (fromKeyType) import GHC.Conc (getNumProcessors) import GHC.IO.Encoding (setLocaleEncoding) import GHC.IO.Handle (hDuplicate) @@ -376,10 +377,10 @@ defaultMain Arguments{..} = do printf "# Shake value store contents(%d):\n" (length values) let keys = nub $ - Key GhcSession : - Key GhcSessionDeps : - [k | (_, k) <- HashMap.keys values, k /= Key GhcSessionIO] - ++ [Key GhcSessionIO] + typeOf GhcSession : + typeOf GhcSessionDeps : + [kty | (fromKeyType -> Just (kty,_)) <- HashMap.keys values, kty /= typeOf GhcSessionIO] ++ + [typeOf GhcSessionIO] measureMemory logger [keys] consoleObserver valuesRef unless (null failed) (exitWith $ ExitFailure (length failed)) diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index 965c05c27e..b611b049a9 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -11,17 +11,20 @@ module Development.IDE.Plugin.Test , blockCommandId ) where -import Control.Concurrent (threadDelay) +import Control.Concurrent (threadDelay) +import Control.Concurrent.Extra (readVar) import Control.Monad import Control.Monad.IO.Class import Control.Monad.STM import Data.Aeson import Data.Aeson.Types import Data.Bifunctor -import Data.CaseInsensitive (CI, original) -import Data.Maybe (isJust) +import Data.CaseInsensitive (CI, original) +import qualified Data.HashMap.Strict as HM +import Data.Maybe (isJust) import Data.String -import Data.Text (Text, pack) +import Data.Text (Text, pack) +import Development.IDE.Core.OfInterest (getFilesOfInterest) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake @@ -29,14 +32,16 @@ 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) -import GHC.Generics (Generic) +import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) +import Development.IDE.Types.Location (fromUri) +import GHC.Generics (Generic) +import Ide.Plugin.Config (CheckParents) import Ide.Types -import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Server as LSP import Language.LSP.Types import System.Time.Extra +type Age = Int data TestRequest = BlockSeconds Seconds -- ^ :: Null | GetInterfaceFilesDir Uri -- ^ :: String @@ -44,6 +49,9 @@ data TestRequest | WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null | WaitForIdeRule String Uri -- ^ :: WaitForIdeRuleResult | GetLastBuildKeys -- ^ :: [String] + | GarbageCollectDirtyKeys CheckParents Age -- ^ :: [String] (list of keys collected) + | GetStoredKeys -- ^ :: [String] (list of keys in store) + | GetFilesOfInterest -- ^ :: [FilePath] deriving Generic deriving anyclass (FromJSON, ToJSON) @@ -93,6 +101,15 @@ testRequestHandler s (WaitForIdeRule k file) = liftIO $ do testRequestHandler s GetLastBuildKeys = liftIO $ do keys <- shakeLastBuildKeys $ shakeDb s return $ Right $ toJSON $ map show keys +testRequestHandler s (GarbageCollectDirtyKeys parents age) = do + res <- liftIO $ runAction "garbage collect dirty" s $ garbageCollectDirtyKeysOlderThan age parents + return $ Right $ toJSON $ map show res +testRequestHandler s GetStoredKeys = do + keys <- liftIO $ HM.keys <$> readVar (state $ shakeExtras s) + return $ Right $ toJSON $ map show keys +testRequestHandler s GetFilesOfInterest = do + ff <- liftIO $ getFilesOfInterest s + return $ Right $ toJSON $ map fromNormalizedFilePath $ HM.keys ff mkResponseError :: Text -> ResponseError mkResponseError msg = ResponseError InvalidRequest msg Nothing diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index 1a8ca906a9..bfd11413fc 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -50,6 +50,8 @@ data IdeOptions = IdeOptions -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants , optReportProgress :: IdeReportProgress -- ^ Whether to report progress during long operations. + , optMaxDirtyAge :: Int + -- ^ Age (in # builds) at which we collect dirty keys , optLanguageSyntax :: String -- ^ the ```language to use , optNewColonConvention :: Bool @@ -137,12 +139,13 @@ defaultIdeOptions session = IdeOptions ,optDefer = IdeDefer True ,optTesting = IdeTesting False ,optCheckProject = pure True - ,optCheckParents = pure CheckOnSaveAndClose + ,optCheckParents = pure CheckOnSave ,optHaddockParse = HaddockParse ,optModifyDynFlags = mempty ,optSkipProgress = defaultSkipProgress ,optProgressStyle = Explicit ,optRunSubset = True + ,optMaxDirtyAge = 100 } defaultSkipProgress :: Typeable a => a -> Bool diff --git a/ghcide/src/Development/IDE/Types/Shake.hs b/ghcide/src/Development/IDE/Types/Shake.hs index 750dbcdd11..8d30b59801 100644 --- a/ghcide/src/Development/IDE/Types/Shake.hs +++ b/ghcide/src/Development/IDE/Types/Shake.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} module Development.IDE.Types.Shake ( Q (..), @@ -12,7 +13,7 @@ module Development.IDE.Types.Shake ShakeValue(..), currentValue, isBadDependency, - toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey) + toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey,fromKey,fromKeyType) where import Control.DeepSeq @@ -21,6 +22,7 @@ import qualified Data.ByteString.Char8 as BS import Data.Dynamic import Data.HashMap.Strict import Data.Hashable +import Data.Typeable (cast) import Data.Vector (Vector) import Development.IDE.Core.PositionMapping import Development.IDE.Graph (Key (..), RuleResult) @@ -29,6 +31,11 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import GHC.Generics import Language.LSP.Types +import Type.Reflection (SomeTypeRep (SomeTypeRep), + pattern App, pattern Con, + typeOf, typeRep, + typeRepTyCon) +import Unsafe.Coerce (unsafeCoerce) data Value v = Succeeded TextDocumentVersion v @@ -49,7 +56,7 @@ data ValueWithDiagnostics = ValueWithDiagnostics !(Value Dynamic) !(Vector FileDiagnostic) -- | The state of the all values and diagnostics -type Values = HashMap (NormalizedFilePath, Key) ValueWithDiagnostics +type Values = HashMap Key ValueWithDiagnostics -- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency -- which short-circuits the rest of the action @@ -64,6 +71,19 @@ isBadDependency x toKey :: Shake.ShakeValue k => k -> NormalizedFilePath -> Key toKey = (Key.) . curry Q +fromKey :: Typeable k => Key -> Maybe (k, NormalizedFilePath) +fromKey (Key k) + | Just (Q (k', f)) <- cast k = Just (k', f) + | otherwise = Nothing + +-- | 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) + -> case unsafeCoerce k of + Q (_ :: (), f) -> Just (SomeTypeRep a, f) + _ -> Nothing + toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k) => k -> Key toNoFileKey k = Key $ Q (k, emptyFilePath) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index ad54f5d6be..2dd58490b4 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -50,7 +50,10 @@ import Development.IDE.Test (Cursor, expectNoMoreDiagnostics, flushMessages, standardizeQuotes, - waitForAction, getInterfaceFilesDir) + getInterfaceFilesDir, + waitForAction, + getStoredKeys, + waitForTypecheck, waitForGC) import Development.IDE.Test.Runfiles import qualified Development.IDE.Types.Diagnostics as Diagnostics import Development.IDE.Types.Location @@ -172,6 +175,7 @@ main = do , clientSettingsTest , codeActionHelperFunctionTests , referenceTests + , garbageCollectionTests ] initializeResponseTests :: TestTree @@ -718,7 +722,7 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r -- Now we edit the document and wait for the given key (if any) changeDoc doc [edit] whenJust mbKey $ \(key, expectedResult) -> do - Right WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc + WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc liftIO $ ideResultSuccess @?= expectedResult -- The 2nd edit cancels the active session and unbreaks the file @@ -732,7 +736,7 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s typeCheck doc = do - Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc liftIO $ assertBool "The file should typecheck" ideResultSuccess -- wait for the debouncer to publish diagnostics if the rule runs liftIO $ sleep 0.2 @@ -5035,7 +5039,7 @@ retryFailedCradle = testSession' "retry failed" $ \dir -> do liftIO $ writeFile hiePath hieContents let aPath = dir "A.hs" doc <- createDoc aPath "haskell" "main = return ()" - Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess -- Fix the cradle and typecheck again @@ -5044,7 +5048,7 @@ retryFailedCradle = testSession' "retry failed" $ \dir -> do sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ List [FileEvent (filePathToUri $ dir "hie.yaml") FcChanged ] - Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess @@ -5123,11 +5127,11 @@ simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraF bPath = dir "b/B.hs" aSource <- liftIO $ readFileUtf8 aPath adoc <- createDoc aPath "haskell" aSource - Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc liftIO $ assertBool "A should typecheck" ideResultSuccess bSource <- liftIO $ readFileUtf8 bPath bdoc <- createDoc bPath "haskell" bSource - Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc liftIO $ assertBool "B should typecheck" ideResultSuccess locs <- getDefinitions bdoc (Position 2 7) let fooL = mkL (adoc ^. L.uri) 2 0 2 3 @@ -5249,7 +5253,7 @@ ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \d -- Check that we wrote the interfaces for B when we saved - Right hidir <- getInterfaceFilesDir bdoc + hidir <- getInterfaceFilesDir bdoc hi_exists <- liftIO $ doesFileExist $ hidir "B.hi" liftIO $ assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists @@ -5832,6 +5836,78 @@ unitTests = do , Progress.tests ] +garbageCollectionTests :: TestTree +garbageCollectionTests = testGroup "garbage collection" + [ testGroup "dirty keys" + [ testSession' "are collected" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + 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]}}" + docA <- generateGarbage "A" dir + keys0 <- getStoredKeys + 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]}}" + docA <- generateGarbage "A" dir + _docB <- generateGarbage "B" dir + + -- garbage collect A keys + keysBeforeGC <- getStoredKeys + 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) + + -- 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) + liftIO $ regeneratedKeys @?= mempty + + , testSession' "regenerate successfully" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + 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 <- 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"] + + 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 + return doc + findResolution_us :: Int -> IO Int findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution" findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index 35ae059500..48fd9fa5bc 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} module Development.IDE.Test @@ -22,6 +23,13 @@ module Development.IDE.Test , waitForAction , getLastBuildKeys , getInterfaceFilesDir + , garbageCollectDirtyKeys + , getFilesOfInterest + , waitForTypecheck + , waitForBuildQueue + , getStoredKeys + , waitForCustomMessage + , waitForGC ) where import Control.Applicative.Combinators @@ -32,10 +40,13 @@ import qualified Data.Aeson as A import Data.Bifunctor (second) import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) +import Data.Text (Text) import qualified Data.Text as T import Development.IDE.Plugin.Test (TestRequest (..), - WaitForIdeRuleResult) + WaitForIdeRuleResult, + ideResultSuccess) import Development.IDE.Test.Diagnostic +import Ide.Plugin.Config (CheckParents) import Language.LSP.Test hiding (message) import qualified Language.LSP.Test as LspTest import Language.LSP.Types hiding @@ -171,23 +182,51 @@ canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePat diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics) diagnostic = LspTest.message STextDocumentPublishDiagnostics -callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b) +callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b callTestPlugin cmd = do let cm = SCustomMethod "test" 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 + return $ case _result of + Left (ResponseError t err _) -> error $ show t <> ": " <> T.unpack err + Right json -> case A.fromJSON json of + A.Success a -> a + A.Error e -> error e -waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) +waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResult waitForAction key TextDocumentIdentifier{_uri} = callTestPlugin (WaitForIdeRule key _uri) -getLastBuildKeys :: Session (Either ResponseError [T.Text]) +getLastBuildKeys :: Session [T.Text] getLastBuildKeys = callTestPlugin GetLastBuildKeys -getInterfaceFilesDir :: TextDocumentIdentifier -> Session (Either ResponseError FilePath) +getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri) + +garbageCollectDirtyKeys :: CheckParents -> Int -> Session [String] +garbageCollectDirtyKeys parents age = callTestPlugin (GarbageCollectDirtyKeys parents age) + +getStoredKeys :: Session [Text] +getStoredKeys = callTestPlugin GetStoredKeys + +waitForTypecheck :: TextDocumentIdentifier -> Session Bool +waitForTypecheck tid = ideResultSuccess <$> waitForAction "typecheck" tid + +waitForBuildQueue :: Session () +waitForBuildQueue = callTestPlugin WaitForShakeQueue + +getFilesOfInterest :: Session [FilePath] +getFilesOfInterest = callTestPlugin GetFilesOfInterest + +waitForCustomMessage :: T.Text -> (A.Value -> Maybe res) -> Session res +waitForCustomMessage msg pred = + skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess (SCustomMethod lbl) (NotMess NotificationMessage{_params = value}) + | lbl == msg -> pred value + _ -> Nothing + +waitForGC :: Session [T.Text] +waitForGC = waitForCustomMessage "ghcide/GC" $ \v -> + case A.fromJSON v of + A.Success x -> Just x + _ -> Nothing diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index 60d7e182b3..b0f296a37a 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-graph -version: 1.5.0.0 +version: 1.5.1.0 synopsis: Haskell Language Server internal graph API description: Please see the README on GitHub at diff --git a/hls-graph/src/Development/IDE/Graph.hs b/hls-graph/src/Development/IDE/Graph.hs index 6bd49e66f1..1561abc35b 100644 --- a/hls-graph/src/Development/IDE/Graph.hs +++ b/hls-graph/src/Development/IDE/Graph.hs @@ -17,6 +17,9 @@ module Development.IDE.Graph( alwaysRerun, -- * Batching reschedule, + -- * Actions for inspecting the keys in the database + getDirtySet, + getKeysAndVisitedAge, ) where import Development.IDE.Graph.Database diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index 5a4d083e7b..96481a6f31 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -8,11 +8,13 @@ module Development.IDE.Graph.Database( shakeRunDatabase, shakeRunDatabaseForKeys, shakeProfileDatabase, + shakeGetBuildStep, + shakeGetDatabaseKeys, + shakeGetDirtySet, shakeLastBuildKeys ) where - import Data.Dynamic -import Data.IORef +import Data.IORef (readIORef) import Data.Maybe import Development.IDE.Graph.Classes () import Development.IDE.Graph.Internal.Action @@ -41,6 +43,22 @@ shakeNewDatabase opts rules = do shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO ([a], [IO ()]) shakeRunDatabase = shakeRunDatabaseForKeys Nothing +-- | Returns the set of dirty keys annotated with their age (in # of builds) +shakeGetDirtySet :: ShakeDatabase -> IO [(Key, Int)] +shakeGetDirtySet (ShakeDatabase _ _ db) = + fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db + +-- | Returns ann approximation of the database keys, +-- annotated with how long ago (in # builds) they were visited +shakeGetDatabaseKeys :: ShakeDatabase -> IO [(Key, Int)] +shakeGetDatabaseKeys (ShakeDatabase _ _ db) = getKeysAndVisitAge db + +-- | Returns the build number +shakeGetBuildStep :: ShakeDatabase -> IO Int +shakeGetBuildStep (ShakeDatabase _ _ db) = do + Step s <- readIORef $ databaseStep db + return s + -- Only valid if we never pull on the results, which we don't unvoid :: Functor m => m () -> m a unvoid = fmap undefined diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index ef1168685b..ad895c17c3 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -15,6 +15,8 @@ module Development.IDE.Graph.Internal.Action , parallel , reschedule , runActions +, Development.IDE.Graph.Internal.Action.getDirtySet +, getKeysAndVisitedAge ) where import Control.Concurrent.Async @@ -123,3 +125,14 @@ runActions :: Database -> [Action a] -> IO [a] runActions db xs = do deps <- newIORef mempty runReaderT (fromAction $ parallel xs) $ SAction db deps + +-- | Returns the set of dirty keys annotated with their age (in # of builds) +getDirtySet :: Action [(Key, Int)] +getDirtySet = do + db <- getDatabase + liftIO $ fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db + +getKeysAndVisitedAge :: Action [(Key, Int)] +getKeysAndVisitedAge = do + db <- getDatabase + liftIO $ Development.IDE.Graph.Internal.Database.getKeysAndVisitAge db diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 5717831c7b..4b8a1d985c 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -11,7 +11,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet) where +module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where import Control.Concurrent.Async import Control.Concurrent.Extra @@ -188,6 +188,16 @@ getDirtySet db = do calcAgeStatus (Dirty x)=calcAge <$> x calcAgeStatus _ = Nothing return $ mapMaybe ((secondM.secondM) calcAgeStatus) dbContents + +-- | Returns ann approximation of the database keys, +-- annotated with how long ago (in # builds) they were visited +getKeysAndVisitAge :: Database -> IO [(Key, Int)] +getKeysAndVisitAge db = do + values <- Ids.elems (databaseValues db) + Step curr <- readIORef (databaseStep db) + let keysWithVisitAge = mapMaybe (secondM (fmap getAge . getResult)) values + getAge Result{resultVisited = Step s} = curr - s + return keysWithVisitAge -------------------------------------------------------------------------------- -- Lazy IO trick diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 3adc0698d5..1bc0ced3a2 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -58,6 +58,8 @@ data SAction = SAction { actionDeps :: !(IORef ResultDeps) } +getDatabase :: Action Database +getDatabase = Action $ asks actionDatabase --------------------------------------------------------------------- -- DATABASE diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index dce08c6e24..6a286a5191 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -37,8 +37,7 @@ data CheckParents -- Note that ordering of constructors is meaningful and must be monotonically -- increasing in the scenarios where parents are checked = NeverCheck - | CheckOnClose - | CheckOnSaveAndClose + | CheckOnSave | AlwaysCheck deriving stock (Eq, Ord, Show, Generic) deriving anyclass (FromJSON, ToJSON) @@ -61,7 +60,7 @@ data Config = instance Default Config where def = Config - { checkParents = CheckOnSaveAndClose + { checkParents = CheckOnSave , checkProject = True , hlintOn = True , diagnosticsOnChange = True