Skip to content

Commit e247ae1

Browse files
soulomoonsoulomoon
committed
use IO [Key]
1 parent 6fc3646 commit e247ae1

File tree

9 files changed

+58
-60
lines changed

9 files changed

+58
-60
lines changed

‎ghcide/session-loader/Development/IDE/Session.hs

Lines changed: 8 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -106,7 +106,7 @@ import qualified Data.HashSet as Set
106106
import Database.SQLite.Simple
107107
import Development.IDE.Core.Tracing (withTrace)
108108
import Development.IDE.Session.Diagnostics (renderCradleError)
109-
import Development.IDE.Types.Shake (WithHieDb)
109+
import Development.IDE.Types.Shake (WithHieDb, toKey)
110110
import HieDb.Create
111111
import HieDb.Types
112112
import HieDb.Utils
@@ -474,10 +474,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
474474
clientConfig <- getClientConfigAction
475475
extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv
476476
} <- getShakeExtras
477-
let invalidateShakeCache :: IO ()
478-
invalidateShakeCache = do
477+
let invalidateShakeCache = do
479478
void $ modifyVar' version succ
480-
join $ atomically $ recordDirtyKeys extras GhcSessionIO [emptyFilePath]
479+
return $ toKey GhcSessionIO emptyFilePath
481480

482481
IdeOptions{ optTesting = IdeTesting optTesting
483482
, optCheckProject = getCheckProject
@@ -516,10 +515,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
516515
HM.unionWith (<>) k $ HM.fromList knownTargets
517516
hasUpdate = if known /= known' then Just (unhashed known') else Nothing
518517
writeTVar knownTargetsVar known'
519-
logDirtyKeys <- recordDirtyKeys extras GetKnownTargets [emptyFilePath]
520-
return (logDirtyKeys >> pure hasUpdate)
518+
return (pure hasUpdate)
521519
for_ hasUpdate $ \x ->
522520
logWith recorder Debug $ LogKnownFilesUpdated x
521+
return $ toKey GetKnownTargets emptyFilePath
523522

524523
-- Create a new HscEnv from a hieYaml root and a set of options
525524
let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)
@@ -617,9 +616,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
617616
Map.insert hieYaml this_flags_map
618617
void $ modifyVar' filesMap $
619618
flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets))
620-
void $ extendKnownTargets all_targets
619+
key1 <- extendKnownTargets all_targets
620+
key2 <- invalidateShakeCache
621+
return [key1, key2]
621622
-- Invalidate all the existing GhcSession build nodes by restarting the Shake session
622-
invalidateShakeCache
623623

624624
-- Typecheck all files in the project on startup
625625
checkProject <- getCheckProject

‎ghcide/src/Development/IDE/Core/FileExists.hs

Lines changed: 7 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,7 @@ import qualified Development.IDE.Core.Shake as Shake
2828
import Development.IDE.Graph
2929
import Development.IDE.Types.Location
3030
import Development.IDE.Types.Options
31+
import Development.IDE.Types.Shake (toKey)
3132
import qualified Focus
3233
import Ide.Logger (Pretty (pretty),
3334
Recorder, WithPriority,
@@ -106,11 +107,11 @@ getFileExistsMapUntracked = do
106107
return v
107108

108109
-- | Modify the global store of file exists.
109-
modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO ()
110+
modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO [Key]
110111
modifyFileExists state changes = do
111112
FileExistsMapVar var <- getIdeGlobalState state
112113
-- Masked to ensure that the previous values are flushed together with the map update
113-
join $ mask_ $ atomicallyNamed "modifyFileExists" $ do
114+
keys <- join $ mask_ $ atomicallyNamed "modifyFileExists" $ do
114115
forM_ changes $ \(f,c) ->
115116
case fromChange c of
116117
Just c' -> STM.focus (Focus.insert c') f var
@@ -120,9 +121,10 @@ modifyFileExists state changes = do
120121
let (fileModifChanges, fileExistChanges) =
121122
partition ((== FileChangeType_Changed) . snd) changes
122123
mapM_ (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges
123-
io1 <- recordDirtyKeys (shakeExtras state) GetFileExists $ map fst fileExistChanges
124-
io2 <- recordDirtyKeys (shakeExtras state) GetModificationTime $ map fst fileModifChanges
125-
return (io1 <> io2)
124+
let keys1 = map (toKey GetFileExists . fst) fileExistChanges
125+
let keys2 = map (toKey GetModificationTime . fst) fileModifChanges
126+
return $ return (keys1 <> keys2)
127+
return keys
126128

127129
fromChange :: FileChangeType -> Maybe Bool
128130
fromChange FileChangeType_Created = Just True

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

Lines changed: 8 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -49,6 +49,7 @@ import Development.IDE.Import.DependencyInformation
4949
import Development.IDE.Types.Diagnostics
5050
import Development.IDE.Types.Location
5151
import Development.IDE.Types.Options
52+
import Development.IDE.Types.Shake (toKey)
5253
import HieDb.Create (deleteMissingRealFiles)
5354
import Ide.Logger (Pretty (pretty),
5455
Priority (Info),
@@ -215,7 +216,7 @@ setFileModified :: Recorder (WithPriority Log)
215216
-> IdeState
216217
-> Bool -- ^ Was the file saved?
217218
-> NormalizedFilePath
218-
-> IO ()
219+
-> IO [Key]
219220
-> IO ()
220221
setFileModified recorder vfs state saved nfp actionBefore = do
221222
ideOptions <- getIdeOptionsIO $ shakeExtras state
@@ -225,8 +226,8 @@ setFileModified recorder vfs state saved nfp actionBefore = do
225226
CheckOnSave -> saved
226227
_ -> False
227228
restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] $ do
228-
actionBefore
229-
join $ atomically $ recordDirtyKeys (shakeExtras state) GetModificationTime [nfp]
229+
keys<-actionBefore
230+
return (toKey GetModificationTime nfp:keys)
230231
when checkParents $
231232
typecheckParents recorder state nfp
232233

@@ -246,13 +247,13 @@ typecheckParentsAction recorder nfp = do
246247
-- | Note that some keys have been modified and restart the session
247248
-- Only valid if the virtual file system was initialised by LSP, as that
248249
-- independently tracks which files are modified.
249-
setSomethingModified :: VFSModified -> IdeState -> String -> IO () -> IO ()
250+
setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO ()
250251
setSomethingModified vfs state reason actionBetweenSession = do
251252
-- Update database to remove any files that might have been renamed/deleted
252253
void $ restartShakeSession (shakeExtras state) vfs reason [] $ do
253-
actionBetweenSession
254-
atomically $ do
255-
writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)
254+
keys <- actionBetweenSession
255+
atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)
256+
return keys
256257

257258
registerFileWatches :: [String] -> LSP.LspT Config IO Bool
258259
registerFileWatches globs = do

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

Lines changed: 8 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -40,6 +40,7 @@ import Development.IDE.Plugin.Completions.Types
4040
import Development.IDE.Types.Exports
4141
import Development.IDE.Types.Location
4242
import Development.IDE.Types.Options (IdeTesting (..))
43+
import Development.IDE.Types.Shake (toKey)
4344
import GHC.TypeLits (KnownSymbol)
4445
import Ide.Logger (Pretty (pretty),
4546
Priority (..),
@@ -103,24 +104,26 @@ getFilesOfInterestUntracked = do
103104
OfInterestVar var <- getIdeGlobalAction
104105
liftIO $ readVar var
105106

106-
addFileOfInterest :: IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO ()
107+
addFileOfInterest :: IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO [Key]
107108
addFileOfInterest state f v = do
108109
OfInterestVar var <- getIdeGlobalState state
109110
(prev, files) <- modifyVar var $ \dict -> do
110111
let (prev, new) = HashMap.alterF (, Just v) f dict
111112
pure (new, (prev, new))
112-
when (prev /= Just v) $ do
113-
join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
113+
if prev /= Just v
114+
then do
114115
logWith (ideLogger state) Debug $
115116
LogSetFilesOfInterest (HashMap.toList files)
117+
return [toKey IsFileOfInterest f]
118+
else return []
116119

117-
deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO ()
120+
deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO [Key]
118121
deleteFileOfInterest state f = do
119122
OfInterestVar var <- getIdeGlobalState state
120123
files <- modifyVar' var $ HashMap.delete f
121-
join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
122124
logWith (ideLogger state) Debug $
123125
LogSetFilesOfInterest (HashMap.toList files)
126+
return [toKey IsFileOfInterest f]
124127
scheduleGarbageCollection :: IdeState -> IO ()
125128
scheduleGarbageCollection state = do
126129
GarbageCollectVar var <- getIdeGlobalState state

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

Lines changed: 6 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -57,7 +57,7 @@ module Development.IDE.Core.Shake(
5757
FileVersion(..),
5858
updatePositionMapping,
5959
updatePositionMappingHelper,
60-
deleteValue, recordDirtyKeys, recordDirtyKeySet,
60+
deleteValue, recordDirtyKeys,
6161
WithProgressFunc, WithIndefiniteProgressFunc,
6262
ProgressEvent(..),
6363
DelayedAction, mkDelayedAction,
@@ -300,7 +300,7 @@ data ShakeExtras = ShakeExtras
300300
:: VFSModified
301301
-> String
302302
-> [DelayedAction ()]
303-
-> IO ()
303+
-> IO [Key]
304304
-> IO ()
305305
#if MIN_VERSION_ghc(9,3,0)
306306
,ideNc :: NameCache
@@ -569,21 +569,10 @@ deleteValue ShakeExtras{dirtyKeys, state} key file = do
569569
modifyTVar' dirtyKeys $ insertKeySet (toKey key file)
570570

571571
recordDirtyKeys
572-
:: Shake.ShakeValue k
573-
=> ShakeExtras
574-
-> k
575-
-> [NormalizedFilePath]
576-
-> STM (IO ())
577-
recordDirtyKeys ShakeExtras{dirtyKeys} key file = do
578-
modifyTVar' dirtyKeys $ \x -> foldl' (flip insertKeySet) x (toKey key <$> file)
579-
return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do
580-
addEvent (fromString $ unlines $ "dirty " <> show key : map fromNormalizedFilePath file)
581-
582-
recordDirtyKeySet
583572
:: ShakeExtras
584573
-> [Key]
585574
-> STM (IO ())
586-
recordDirtyKeySet ShakeExtras{dirtyKeys} keys = do
575+
recordDirtyKeys ShakeExtras{dirtyKeys} keys = do
587576
modifyTVar' dirtyKeys $ \x -> foldl' (flip insertKeySet) x keys
588577
return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do
589578
addEvent (fromString $ unlines $ "dirty " : map show keys)
@@ -769,13 +758,14 @@ delayedAction a = do
769758
-- | Restart the current 'ShakeSession' with the given system actions.
770759
-- Any actions running in the current session will be aborted,
771760
-- but actions added via 'shakeEnqueue' will be requeued.
772-
shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO () -> IO ()
761+
shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()
773762
shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession =
774763
withMVar'
775764
shakeSession
776765
(\runner -> do
777766
(stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner
778-
ioActionBetweenShakeSession
767+
keys <- ioActionBetweenShakeSession
768+
join $ atomically $ recordDirtyKeys shakeExtras keys
779769
res <- shakeDatabaseProfile shakeDb
780770
backlog <- readTVarIO $ dirtyKeys shakeExtras
781771
queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -96,8 +96,8 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat
9696
whenUriFile _uri $ \file -> do
9797
let msg = "Closed text document: " <> getUri _uri
9898
setSomethingModified (VFSModified vfs) ide (Text.unpack msg) $ do
99-
deleteFileOfInterest ide file
10099
scheduleGarbageCollection ide
100+
deleteFileOfInterest ide file
101101
logWith recorder Debug $ LogClosedTextDocument _uri
102102

103103
, mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWatchedFiles $
@@ -117,8 +117,8 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat
117117
let msg = show fileEvents'
118118
logWith recorder Debug $ LogWatchedFileEvents (Text.pack msg)
119119
setSomethingModified (VFSModified vfs) ide msg $ do
120-
modifyFileExists ide fileEvents'
121120
resetFileStore ide fileEvents'
121+
modifyFileExists ide fileEvents'
122122

123123
, mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWorkspaceFolders $
124124
\ide _ _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do

‎ghcide/src/Development/IDE/Main.hs

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -56,7 +56,6 @@ import Development.IDE.Core.Service (initialise,
5656
import qualified Development.IDE.Core.Service as Service
5757
import Development.IDE.Core.Shake (IdeState (shakeExtras),
5858
IndexQueue,
59-
recordDirtyKeys,
6059
shakeSessionInit,
6160
uses)
6261
import qualified Development.IDE.Core.Shake as Shake
@@ -367,7 +366,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
367366
setSomethingModified Shake.VFSUnmodified ide "config change" $ do
368367
logWith recorder Debug $ LogConfigurationChange msg
369368
modifyClientSettings ide (const $ Just cfgObj)
370-
join $ atomically $ recordDirtyKeys (shakeExtras ide) Rules.GetClientSettings [emptyFilePath]
369+
return [toKey Rules.GetClientSettings emptyFilePath]
371370

372371
runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup
373372
dumpSTMStats

‎plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs

Lines changed: 13 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -24,9 +24,10 @@ import Data.Typeable
2424
import Development.IDE as D
2525
import Development.IDE.Core.Shake (restartShakeSession)
2626
import qualified Development.IDE.Core.Shake as Shake
27-
import Development.IDE.Graph (alwaysRerun)
27+
import Development.IDE.Graph (Key, alwaysRerun)
2828
import qualified Development.IDE.Plugin.Completions.Logic as Ghcide
2929
import qualified Development.IDE.Plugin.Completions.Types as Ghcide
30+
import Development.IDE.Types.Shake (toKey)
3031
import GHC.Generics
3132
import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes
3233
import qualified Ide.Plugin.Cabal.Completion.Completions as Completions
@@ -130,11 +131,11 @@ needs to be re-parsed. That's what we do when we record the dirty key that our p
130131
rule depends on.
131132
Then we restart the shake session, so that changes to our virtual files are actually picked up.
132133
-}
133-
restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO () -> IO ()
134+
restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO ()
134135
restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = do
135136
restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do
136-
actionBetweenSession
137-
join $ atomically $ Shake.recordDirtyKeys shakeExtras GetModificationTime [file]
137+
keys <- actionBetweenSession
138+
return (toKey GetModificationTime file:keys)
138139

139140
-- ----------------------------------------------------------------
140141
-- Plugin Rules
@@ -250,24 +251,26 @@ getCabalFilesOfInterestUntracked = do
250251
OfInterestCabalVar var <- Shake.getIdeGlobalAction
251252
liftIO $ readVar var
252253

253-
addFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO ()
254+
addFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO [Key]
254255
addFileOfInterest recorder state f v = do
255256
OfInterestCabalVar var <- Shake.getIdeGlobalState state
256257
(prev, files) <- modifyVar var $ \dict -> do
257258
let (prev, new) = HashMap.alterF (,Just v) f dict
258259
pure (new, (prev, new))
259-
when (prev /= Just v) $ do
260-
join $ atomically $ Shake.recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
261-
log' Debug $ LogFOI files
260+
if prev /= Just v
261+
then do
262+
log' Debug $ LogFOI files
263+
return [toKey IsCabalFileOfInterest f]
264+
else return []
262265
where
263266
log' = logWith recorder
264267

265-
deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO ()
268+
deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO [Key]
266269
deleteFileOfInterest recorder state f = do
267270
OfInterestCabalVar var <- Shake.getIdeGlobalState state
268271
files <- modifyVar' var $ HashMap.delete f
269-
join $ atomically $ Shake.recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
270272
log' Debug $ LogFOI files
273+
return [toKey IsFileOfInterest f]
271274
where
272275
log' = logWith recorder
273276

‎plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -85,8 +85,7 @@ import Development.IDE.Core.RuleTypes (GetLinkable (GetL
8585
GetModuleGraph (GetModuleGraph),
8686
GhcSessionDeps (GhcSessionDeps),
8787
ModSummaryResult (msrModSummary))
88-
import Development.IDE.Core.Shake (VFSModified (VFSUnmodified),
89-
recordDirtyKeys)
88+
import Development.IDE.Core.Shake (VFSModified (VFSUnmodified))
9089
import qualified Development.IDE.GHC.Compat.Core as Compat (InteractiveImport (IIModule))
9190
import qualified Development.IDE.GHC.Compat.Core as SrcLoc (HasSrcSpan (getLoc),
9291
unLoc)
@@ -216,12 +215,13 @@ runEvalCmd recorder plId st mtoken EvalParams{..} =
216215
-- enable codegen for the module which we need to evaluate.
217216
final_hscEnv <- liftIO $ bracket_
218217
(setSomethingModified VFSUnmodified st "Eval" $ do
219-
join $ atomically $ recordDirtyKeys (shakeExtras st) IsEvaluating [nfp]
220218
queueForEvaluation st nfp
219+
return [toKey IsEvaluating nfp]
221220
)
222221
(setSomethingModified VFSUnmodified st "Eval" $ do
223-
join $ atomically $ recordDirtyKeys (shakeExtras st) IsEvaluating [nfp]
224-
unqueueForEvaluation st nfp)
222+
unqueueForEvaluation st nfp
223+
return [toKey IsEvaluating nfp]
224+
)
225225
(initialiseSessionForEval (needsQuickCheck tests) st nfp)
226226

227227
evalCfg <- liftIO $ runAction "eval: config" st $ getEvalConfig plId

0 commit comments

Comments
 (0)