diff --git a/ghcide/.hlint.yaml b/ghcide/.hlint.yaml
index 725604f7df41f2603d1e60681649f4293f02fc9e..01f035184a4ce1e7b6436ffe2ab14439954a3423 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 0ff9eb5adc794dbb2268b591bb70aca92bc61f0e..ccd1b0aa7d4e6e92f8c6e7516751985f53dd7110 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 2cc9d1c7f1c802fa0fca3c1c1234138fdd605107..fe52b65975f7e02327b6d2e8c77495d7c7fcae5f 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 880d9f456df722a4c8856da2197759dc3db457b9..bc53fba870754cf378c45b353eb3ba1109f9773b 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 60b7c34fe32ada2debff05d80557f6d81e371d8a..5670cb540bf9c120ac27ee3eb070a1a4111eea69 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 0c24c8996cf2a8641a4fc94ccc2a789ae9367282..d81c90d883066bf25f618e0938a64f2ad0a50356 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 b2901bf32c4932e6547bf181846cd7c0278b1506..0c7ba6236eb3fe79a73ccc627df7e2c4e63eea2a 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 5f1defb02761e2b391e562b4a5da959a9a3cc2d8..cb084ef11f2483c6b52ff89b83d5df692a0484af 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 965c05c27eee1c245844e8bda652a448f80cac93..b611b049a9d5189d772276bdc20690572896b7da 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 1a8ca906a9f52817af67786d20dbe70745a1fff2..bfd11413fc4af52ce0d0c63d06bc0bcc85065a1d 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 750dbcdd11f4d837f3a74df51a4c16847455b2e8..8d30b59801008bcf3d2b0bb9afc83622730e1002 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 ad54f5d6be1bdb4e2bf55547ccd249430a10867f..2dd58490b4992fa77ba832f1ec72269af1142d98 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 35ae059500e82d02b356b270cfcc659f7bc366ad..48fd9fa5bc57724837d8b38537c9501e0e2e6532 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 60d7e182b368134b3275aa823877b89cd3b43540..b0f296a37a445b1e8b3b4800aab89274a0143b7d 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 <https://github.com/haskell/haskell-language-server#readme>
diff --git a/hls-graph/src/Development/IDE/Graph.hs b/hls-graph/src/Development/IDE/Graph.hs
index 6bd49e66f1bdcc5943fe65e9f4cf067cf16ae52f..1561abc35b347ab1244d758687b1fd441969a0f0 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 5a4d083e7b2a2e4686b4ee0dacbcef17c4d91a9e..96481a6f315b13f32fc6239c1f2ea1d48c90f8da 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 ef1168685b2ab279c0ddf08a601fa5b7ca2d6b79..ad895c17c364cad2e1f0b80f9350e25df1f46cba 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 5717831c7b3ba5a5cc711a0e0f009d305c0ab442..4b8a1d985cd85429b7942741f5842b339401a0ef 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 3adc0698d5697b8db86aa7b458040df194fbbcc0..1bc0ced3a212649ee3448a4b9d8e708fab7a9c7f 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 dce08c6e24631789fac31707521248320515fc9c..6a286a519107e796d809d205171e60de986732ad 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