From 52c7f7ad656aeddcef315b6150316cd9c6a27ed3 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Tue, 22 Feb 2022 19:54:05 +0530 Subject: [PATCH 1/7] Track file versions accurately. This patch does two things: 1. It allows us to track the versions of `Values` which don't come from the VFS, as long as those particular `Values` depended on the `GetModificationTime` rule This is necessary for the recompilation avoidance scheme implemented in #2316 2. It removes the VFSHandle type and instead relies on snapshots of the VFS state taken on every rebuild of the shake session to ensure that we see a consistent VFS state throughout each individual build. With regards to 2, this is necessary because the lsp library mutates its VFS file store as changes come in. This can lead to scenarios where the HLS build session can see inconsistent views of the VFS. One such scenario is. 1. HLS build starts, with VFS state A 2. LSP Change request comes in and lsp updates its internal VFS state to B 3. HLS build continues, now consulting VFS state B 4. lsp calls the HLS file change handler, interrupting the build and restarting it. However, the build might have completed, or cached results computed using an inconsistent VFS state. --- ghcide/ghcide.cabal | 2 + ghcide/src/Development/IDE/Core/FileExists.hs | 51 ++++---- ghcide/src/Development/IDE/Core/FileStore.hs | 103 ++++------------ ghcide/src/Development/IDE/Core/FileUtils.hs | 31 +++++ ghcide/src/Development/IDE/Core/RuleTypes.hs | 8 +- ghcide/src/Development/IDE/Core/Rules.hs | 15 ++- ghcide/src/Development/IDE/Core/Service.hs | 6 +- ghcide/src/Development/IDE/Core/Shake.hs | 110 +++++++++++------- .../src/Development/IDE/LSP/LanguageServer.hs | 5 +- ghcide/src/Development/IDE/Main.hs | 12 +- ghcide/src/Development/IDE/Types/Exports.hs | 3 +- ghcide/src/Development/IDE/Types/Shake.hs | 5 +- hls-plugin-api/hls-plugin-api.cabal | 2 +- 13 files changed, 172 insertions(+), 181 deletions(-) create mode 100644 ghcide/src/Development/IDE/Core/FileUtils.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index e390813cd4..097994e925 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -50,6 +50,7 @@ library dlist, exceptions, extra >= 1.7.4, + enummapset, filepath, fingertree, focus, @@ -147,6 +148,7 @@ library Development.IDE.Main.HeapStats Development.IDE.Core.Debouncer Development.IDE.Core.FileStore + Development.IDE.Core.FileUtils Development.IDE.Core.IdeConfiguration Development.IDE.Core.OfInterest Development.IDE.Core.PositionMapping diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index d30f8047f2..0b032e8686 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -173,8 +173,8 @@ allExtensions opts = [extIncBoot | ext <- optExtensions opts, extIncBoot <- [ext -- | Installs the 'getFileExists' rules. -- Provides a fast implementation if client supports dynamic watched files. -- Creates a global state as a side effect in that case. -fileExistsRules :: Recorder (WithPriority Log) -> Maybe (LanguageContextEnv Config) -> VFSHandle -> Rules () -fileExistsRules recorder lspEnv vfs = do +fileExistsRules :: Recorder (WithPriority Log) -> Maybe (LanguageContextEnv Config) -> Rules () +fileExistsRules recorder lspEnv = do supportsWatchedFiles <- case lspEnv of Nothing -> pure False Just lspEnv' -> liftIO $ runLspT lspEnv' isWatchSupported @@ -195,19 +195,19 @@ fileExistsRules recorder lspEnv vfs = do else const $ pure False if supportsWatchedFiles - then fileExistsRulesFast recorder isWatched vfs - else fileExistsRulesSlow recorder vfs + then fileExistsRulesFast recorder isWatched + else fileExistsRulesSlow recorder - fileStoreRules (cmapWithPrio LogFileStore recorder) vfs isWatched + fileStoreRules (cmapWithPrio LogFileStore recorder) isWatched -- Requires an lsp client that provides WatchedFiles notifications, but assumes that this has already been checked. -fileExistsRulesFast :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> VFSHandle -> Rules () -fileExistsRulesFast recorder isWatched vfs = +fileExistsRulesFast :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () +fileExistsRulesFast recorder isWatched = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> do isWF <- isWatched file if isWF - then fileExistsFast vfs file - else fileExistsSlow vfs file + then fileExistsFast file + else fileExistsSlow file {- Note [Invalidating file existence results] We have two mechanisms for getting file existence information: @@ -225,8 +225,8 @@ For the VFS lookup, however, we won't get prompted to flush the result, so inste we use 'alwaysRerun'. -} -fileExistsFast :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool) -fileExistsFast vfs file = do +fileExistsFast :: NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool) +fileExistsFast file = do -- Could in principle use 'alwaysRerun' here, but it's too slwo, See Note [Invalidating file existence results] mp <- getFileExistsMapUntracked @@ -235,28 +235,27 @@ fileExistsFast vfs file = do Just exist -> pure exist -- We don't know about it: use the slow route. -- Note that we do *not* call 'fileExistsSlow', as that would trigger 'alwaysRerun'. - Nothing -> liftIO $ getFileExistsVFS vfs file + Nothing -> getFileExistsVFS file pure (summarizeExists exist, Just exist) summarizeExists :: Bool -> Maybe BS.ByteString summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty -fileExistsRulesSlow :: Recorder (WithPriority Log) -> VFSHandle -> Rules () -fileExistsRulesSlow recorder vfs = - defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> fileExistsSlow vfs file +fileExistsRulesSlow :: Recorder (WithPriority Log) -> Rules () +fileExistsRulesSlow recorder = + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> fileExistsSlow file -fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool) -fileExistsSlow vfs file = do +fileExistsSlow :: NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool) +fileExistsSlow file = do -- See Note [Invalidating file existence results] alwaysRerun - exist <- liftIO $ getFileExistsVFS vfs file + exist <- getFileExistsVFS file pure (summarizeExists exist, Just exist) -getFileExistsVFS :: VFSHandle -> NormalizedFilePath -> IO Bool -getFileExistsVFS vfs file = do - -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute - -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly - -- cached 'No' rather than an exception in the wrong place - handle (\(_ :: IOException) -> return False) $ - (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^ - Dir.doesFileExist (fromNormalizedFilePath file) +getFileExistsVFS :: NormalizedFilePath -> Action Bool +getFileExistsVFS file = do + vf <- getVirtualFile file + if isJust vf + then pure True + else liftIO $ handle (\(_ :: IOException) -> return False) $ + Dir.doesFileExist (fromNormalizedFilePath file) diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 81a2fea695..c48e2f4919 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -5,15 +5,11 @@ module Development.IDE.Core.FileStore( getFileContents, - getVirtualFile, setFileModified, setSomethingModified, fileStoreRules, modificationTime, typecheckParents, - VFSHandle, - makeVFSHandle, - makeLSPVFSHandle, resetFileStore, resetInterfaceStore, getModificationTimeImpl, @@ -28,20 +24,18 @@ module Development.IDE.Core.FileStore( import Control.Concurrent.STM.Stats (STM, atomically, modifyTVar') import Control.Concurrent.STM.TQueue (writeTQueue) -import Control.Concurrent.Strict import Control.Exception import Control.Monad.Extra import Control.Monad.IO.Class import qualified Data.ByteString as BS import Data.Either.Extra -import qualified Data.Map.Strict as Map -import Data.Maybe import qualified Data.Rope.UTF16 as Rope import qualified Data.Text as T import Data.Time import Data.Time.Clock.POSIX import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log) +import Development.IDE.Core.FileUtils import Development.IDE.GHC.Orphans () import Development.IDE.Graph import Development.IDE.Import.DependencyInformation @@ -56,8 +50,6 @@ import System.IO.Error #ifdef mingw32_HOST_OS import qualified System.Directory as Dir #else -import System.Posix.Files (getFileStatus, - modificationTimeHiRes) #endif import qualified Development.IDE.Types.Logger as L @@ -76,8 +68,6 @@ import Development.IDE.Types.Logger (Pretty (pretty), cmapWithPrio, logWith, viaShow, (<+>)) -import Language.LSP.Server hiding - (getVirtualFile) import qualified Language.LSP.Server as LSP import Language.LSP.Types (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions), FileChangeType (FcChanged), @@ -106,27 +96,6 @@ instance Pretty Log where <+> pretty (fmap (fmap show) reverseDepPaths) LogShake log -> pretty log -makeVFSHandle :: IO VFSHandle -makeVFSHandle = do - vfsVar <- newVar (1, Map.empty) - pure VFSHandle - { getVirtualFile = \uri -> do - (_nextVersion, vfs) <- readVar vfsVar - pure $ Map.lookup uri vfs - , setVirtualFileContents = Just $ \uri content -> - void $ modifyVar' vfsVar $ \(nextVersion, vfs) -> (nextVersion + 1, ) $ - case content of - Nothing -> Map.delete uri vfs - -- The second version number is only used in persistFileVFS which we do not use so we set it to 0. - Just content -> Map.insert uri (VirtualFile nextVersion 0 (Rope.fromText content)) vfs - } - -makeLSPVFSHandle :: LanguageContextEnv c -> VFSHandle -makeLSPVFSHandle lspEnv = VFSHandle - { getVirtualFile = runLspT lspEnv . LSP.getVirtualFile - , setVirtualFileContents = Nothing - } - addWatchedFileRule :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \AddWatchedFile f -> do isAlreadyWatched <- isWatched f @@ -140,20 +109,19 @@ addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogSha Nothing -> pure $ Just False -getModificationTimeRule :: Recorder (WithPriority Log) -> VFSHandle -> Rules () -getModificationTimeRule recorder vfs = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \(GetModificationTime_ missingFileDiags) file -> - getModificationTimeImpl vfs missingFileDiags file +getModificationTimeRule :: Recorder (WithPriority Log) -> Rules () +getModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \(GetModificationTime_ missingFileDiags) file -> + getModificationTimeImpl missingFileDiags file -getModificationTimeImpl :: VFSHandle - -> Bool - -> NormalizedFilePath - -> Action - (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion)) -getModificationTimeImpl vfs missingFileDiags file = do +getModificationTimeImpl + :: Bool + -> NormalizedFilePath + -> Action (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion)) +getModificationTimeImpl missingFileDiags file = do let file' = fromNormalizedFilePath file let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time)) - mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file - case mbVirtual of + mbVf <- getVirtualFile file + case mbVf of Just (virtualFileVersion -> ver) -> do alwaysRerun pure (Just $ LBS.toStrict $ B.encode ver, ([], Just $ VFSVersion ver)) @@ -206,43 +174,23 @@ resetFileStore ideState changes = mask $ \_ -> do _ -> pure () --- Dir.getModificationTime is surprisingly slow since it performs --- a ton of conversions. Since we do not actually care about --- the format of the time, we can get away with something cheaper. --- For now, we only try to do this on Unix systems where it seems to get the --- time spent checking file modifications (which happens on every change) --- from > 0.5s to ~0.15s. --- We might also want to try speeding this up on Windows at some point. --- TODO leverage DidChangeWatchedFile lsp notifications on clients that --- support them, as done for GetFileExists -getModTime :: FilePath -> IO POSIXTime -getModTime f = -#ifdef mingw32_HOST_OS - utcTimeToPOSIXSeconds <$> Dir.getModificationTime f -#else - modificationTimeHiRes <$> getFileStatus f -#endif - modificationTime :: FileVersion -> Maybe UTCTime modificationTime VFSVersion{} = Nothing modificationTime (ModificationTime posix) = Just $ posixSecondsToUTCTime posix -getFileContentsRule :: Recorder (WithPriority Log) -> VFSHandle -> Rules () -getFileContentsRule recorder vfs = define (cmapWithPrio LogShake recorder) $ \GetFileContents file -> getFileContentsImpl vfs file +getFileContentsRule :: Recorder (WithPriority Log) -> Rules () +getFileContentsRule recorder = define (cmapWithPrio LogShake recorder) $ \GetFileContents file -> getFileContentsImpl file getFileContentsImpl - :: VFSHandle - -> NormalizedFilePath + :: NormalizedFilePath -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe T.Text)) -getFileContentsImpl vfs file = do +getFileContentsImpl file = do -- need to depend on modification time to introduce a dependency with Cutoff time <- use_ GetModificationTime file - res <- liftIO $ ideTryIOException file $ do - mbVirtual <- getVirtualFile vfs $ filePathToUri' file + res <- do + mbVirtual <- getVirtualFile file pure $ Rope.toText . _text <$> mbVirtual - case res of - Left err -> return ([err], Nothing) - Right contents -> return ([], Just (time, contents)) + pure ([], Just (time, res)) ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a) ideTryIOException fp act = @@ -266,11 +214,10 @@ getFileContents f = do pure $ posixSecondsToUTCTime posix return (modTime, txt) -fileStoreRules :: Recorder (WithPriority Log) -> VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules () -fileStoreRules recorder vfs isWatched = do - addIdeGlobal vfs - getModificationTimeRule recorder vfs - getFileContentsRule recorder vfs +fileStoreRules :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () +fileStoreRules recorder isWatched = do + getModificationTimeRule recorder + getFileContentsRule recorder addWatchedFileRule recorder isWatched -- | Note that some buffer for a specific file has been modified but not @@ -287,9 +234,6 @@ setFileModified recorder state saved nfp = do AlwaysCheck -> True CheckOnSave -> saved _ -> False - VFSHandle{..} <- getIdeGlobalState state - when (isJust setVirtualFileContents) $ - fail "setFileModified can't be called on this type of VFSHandle" join $ atomically $ recordDirtyKeys (shakeExtras state) GetModificationTime [nfp] restartShakeSession (shakeExtras state) (fromNormalizedFilePath nfp ++ " (modified)") [] when checkParents $ @@ -314,9 +258,6 @@ typecheckParentsAction recorder nfp = do -- independently tracks which files are modified. setSomethingModified :: IdeState -> [Key] -> String -> IO () setSomethingModified state keys reason = do - VFSHandle{..} <- getIdeGlobalState state - when (isJust setVirtualFileContents) $ - fail "setSomethingModified can't be called on this type of VFSHandle" -- Update database to remove any files that might have been renamed/deleted atomically $ do writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) diff --git a/ghcide/src/Development/IDE/Core/FileUtils.hs b/ghcide/src/Development/IDE/Core/FileUtils.hs new file mode 100644 index 0000000000..1cbfa0ee0b --- /dev/null +++ b/ghcide/src/Development/IDE/Core/FileUtils.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE CPP #-} + +module Development.IDE.Core.FileUtils( + getModTime, + ) where + + +import Data.Time.Clock.POSIX +#ifdef mingw32_HOST_OS +import qualified System.Directory as Dir +#else +import System.Posix.Files (getFileStatus, + modificationTimeHiRes) +#endif + +-- Dir.getModificationTime is surprisingly slow since it performs +-- a ton of conversions. Since we do not actually care about +-- the format of the time, we can get away with something cheaper. +-- For now, we only try to do this on Unix systems where it seems to get the +-- time spent checking file modifications (which happens on every change) +-- from > 0.5s to ~0.15s. +-- We might also want to try speeding this up on Windows at some point. +-- TODO leverage DidChangeWatchedFile lsp notifications on clients that +-- support them, as done for GetFileExists +getModTime :: FilePath -> IO POSIXTime +getModTime f = +#ifdef mingw32_HOST_OS + utcTimeToPOSIXSeconds <$> Dir.getModificationTime f +#else + modificationTimeHiRes <$> getFileStatus f +#endif diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 5b14d9b4e8..ecece0cd9b 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -290,10 +290,12 @@ pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True} -- | Get the modification time of a file. type instance RuleResult GetModificationTime = FileVersion +-- | Either athe mtime from disk or an LSP version +-- LSP versions always compare as greater than on disk versions data FileVersion - = VFSVersion !Int32 - | ModificationTime !POSIXTime - deriving (Show, Generic) + = ModificationTime !POSIXTime + | VFSVersion !Int32 + deriving (Show, Generic, Eq, Ord) instance NFData FileVersion diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 5e8b33a28c..d4a51dd97d 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -85,6 +85,7 @@ import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HashSet import Data.Hashable import Data.IORef +import Control.Concurrent.STM.TVar import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import Data.List @@ -99,8 +100,7 @@ import Data.Tuple.Extra import Development.IDE.Core.Compile import Development.IDE.Core.FileExists hiding (LogShake, Log) import Development.IDE.Core.FileStore (getFileContents, - modificationTime, - resetInterfaceStore) + resetInterfaceStore, modificationTime) import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.OfInterest hiding (LogShake, Log) import Development.IDE.Core.PositionMapping @@ -555,12 +555,11 @@ getHieAstsRule recorder = persistentHieFileRule :: Recorder (WithPriority Log) -> Rules () persistentHieFileRule recorder = addPersistentRule GetHieAst $ \file -> runMaybeT $ do res <- readHieFileForSrcFromDisk recorder file - vfs <- asks vfs - (currentSource,ver) <- liftIO $ do - mvf <- getVirtualFile vfs $ filePathToUri' file - case mvf of - Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file) - Just vf -> pure (Rope.toText $ _text vf, Just $ _lsp_version vf) + vfsRef <- asks vfs + vfsData <- liftIO $ vfsMap <$> readTVarIO vfsRef + (currentSource, ver) <- liftIO $ case M.lookup (filePathToUri' file) vfsData of + Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file) + Just vf -> pure (Rope.toText $ _text vf, Just $ _lsp_version vf) let refmap = Compat.generateReferencesMap . Compat.getAsts . Compat.hie_asts $ res del = deltaFromDiff (T.decodeUtf8 $ Compat.hie_hs_src res) currentSource pure (HAR (Compat.hie_module res) (Compat.hie_asts res) refmap mempty (HieFromDisk res),del,ver) diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index d190a0d6cf..0dd04a2cd7 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -66,11 +66,10 @@ initialise :: Recorder (WithPriority Log) -> Logger -> Debouncer LSP.NormalizedUri -> IdeOptions - -> VFSHandle -> WithHieDb -> IndexQueue -> IO IdeState -initialise recorder defaultConfig mainRule lspEnv logger debouncer options vfs withHieDb hiedbChan = do +initialise recorder defaultConfig mainRule lspEnv logger debouncer options withHieDb hiedbChan = do shakeProfiling <- do let fromConf = optShakeProfiling options fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING" @@ -86,12 +85,11 @@ initialise recorder defaultConfig mainRule lspEnv logger debouncer options vfs w (optTesting options) withHieDb hiedbChan - vfs (optShakeOptions options) $ do addIdeGlobal $ GlobalIdeOptions options ofInterestRules (cmapWithPrio LogOfInterest recorder) - fileExistsRules (cmapWithPrio LogFileExists recorder) lspEnv vfs + fileExistsRules (cmapWithPrio LogFileExists recorder) lspEnv mainRule -- | Shutdown the Compiler Service. diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index fec940731a..beab767454 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -58,6 +58,7 @@ module Development.IDE.Core.Shake( setPriority, ideLogger, actionLogger, + getVirtualFile, FileVersion(..), Priority(..), updatePositionMapping, @@ -73,7 +74,6 @@ module Development.IDE.Core.Shake( IndexQueue, HieDb, HieDbWriter(..), - VFSHandle(..), addPersistentRule, garbageCollectDirtyKeys, garbageCollectDirtyKeysOlderThan, @@ -94,7 +94,6 @@ import qualified Data.HashMap.Strict as HMap import Data.Hashable import Data.List.Extra (foldl', partition, takeEnd) -import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.SortedList as SL @@ -168,6 +167,10 @@ import qualified Ide.PluginUtils as HLS import Ide.Types (PluginId) import qualified "list-t" ListT import qualified StmContainers.Map as STM +import Data.Functor ((<&>)) +import Development.IDE.Core.FileUtils (getModTime) +import Data.EnumMap.Strict (EnumMap) +import qualified Data.EnumMap.Strict as EM data Log = LogCreateHieDbExportsMapStart @@ -242,7 +245,7 @@ data ShakeExtras = ShakeExtras ,publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic] -- ^ This represents the set of diagnostics that we have published. -- Due to debouncing not every change might get published. - ,positionMapping :: STM.Map NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)) + ,positionMapping :: STM.Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping)) -- ^ Map from a text document version to a PositionMapping that describes how to map -- positions in a version of that document to positions in the latest version -- First mapping is delta from previous version and second one is an @@ -267,8 +270,12 @@ data ShakeExtras = ShakeExtras , persistentKeys :: TVar (HMap.HashMap Key GetStalePersistent) -- ^ Registery for functions that compute/get "stale" results for the rule -- (possibly from disk) - -- Small and immutable after startup, so not worth using an STM.Map. - , vfs :: VFSHandle + , vfs :: TVar VFS + -- ^ A snapshot of the current state of the virtual file system. Updated on shakeRestart + -- VFS state is managed by LSP. However, the state according to the lsp library may be newer than the state of the current session, + -- leaving us vulnerable to suble race conditions. To avoid this, we take a snapshot of the state of the VFS on every + -- restart, so that the whole session sees a single consistent view of the VFS. + -- We don't need a STM.Map because we never update individual keys ourselves. , defaultConfig :: Config -- ^ Default HLS config, only relevant if the client does not provide any Config , dirtyKeys :: TVar (HashSet Key) @@ -309,18 +316,17 @@ addPersistentRule k getVal = do class Typeable a => IsIdeGlobal a where +-- | Read a virtual file from the current snapshot +getVirtualFile :: NormalizedFilePath -> Action (Maybe VirtualFile) +getVirtualFile nf = do + vfs <- fmap vfsMap . liftIO . readTVarIO . vfs =<< getShakeExtras + pure $! Map.lookup (filePathToUri' nf) vfs -- Don't leak a reference to the entire map + +-- Take a snapshot of the current LSP VFS +vfsSnapshot :: Maybe (LSP.LanguageContextEnv a) -> IO VFS +vfsSnapshot Nothing = pure $ VFS mempty "" +vfsSnapshot (Just lspEnv) = LSP.runLspT lspEnv $ LSP.getVirtualFiles --- | haskell-lsp manages the VFS internally and automatically so we cannot use --- the builtin VFS without spawning up an LSP server. To be able to test things --- like `setBufferModified` we abstract over the VFS implementation. -data VFSHandle = VFSHandle - { getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile) - -- ^ get the contents of a virtual file - , setVirtualFileContents :: Maybe (NormalizedUri -> Maybe T.Text -> IO ()) - -- ^ set a specific file to a value. If Nothing then we are ignoring these - -- signals anyway so can just say something was modified - } -instance IsIdeGlobal VFSHandle addIdeGlobal :: IsIdeGlobal a => a -> Rules () addIdeGlobal x = do @@ -333,7 +339,6 @@ addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) = Just _ -> error $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty Nothing -> HMap.insert ty (toDyn x) mp - getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a getIdeGlobalExtras ShakeExtras{globals} = do let typ = typeRep (Proxy :: Proxy a) @@ -386,13 +391,18 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do f <- MaybeT $ pure $ HMap.lookup (Key k) pmap (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file MaybeT $ pure $ (,del,ver) <$> fromDynamic dv - atomicallyNamed "lastValueIO" $ case mv of - Nothing -> do + case mv of + Nothing -> atomicallyNamed "lastValueIO 1" $ do STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k file) state return Nothing Just (v,del,ver) -> do - STM.focus (Focus.alter (alterValue $ Stale (Just del) ver (toDyn v))) (toKey k file) state - Just . (v,) . addDelta del <$> mappingForVersion positionMapping file ver + actual_version <- case ver of + Just ver -> pure (Just $ VFSVersion ver) + Nothing -> (Just . ModificationTime <$> getModTime (fromNormalizedFilePath file)) + `catch` (\(_ :: IOException) -> pure Nothing) + atomicallyNamed "lastValueIO 2" $ do + STM.focus (Focus.alter (alterValue $ Stale (Just del) actual_version (toDyn v))) (toKey k file) state + Just . (v,) . addDelta del <$> mappingForVersion positionMapping file actual_version -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics alterValue new Nothing = Just (ValueWithDiagnostics new mempty) -- If it wasn't in the map, give it empty diagnostics @@ -420,13 +430,14 @@ lastValue key file = do liftIO $ lastValueIO s key file mappingForVersion - :: STM.Map NormalizedUri (Map TextDocumentVersion (a, PositionMapping)) + :: STM.Map NormalizedUri (EnumMap Int32 (a, PositionMapping)) -> NormalizedFilePath - -> TextDocumentVersion + -> Maybe FileVersion -> STM PositionMapping -mappingForVersion allMappings file ver = do +mappingForVersion allMappings file (Just (VFSVersion ver)) = do mapping <- STM.lookup (filePathToUri' file) allMappings - return $ maybe zeroMapping snd $ Map.lookup ver =<< mapping + return $ maybe zeroMapping snd $ EM.lookup ver =<< mapping +mappingForVersion _ _ _ = pure zeroMapping type IdeRule k v = ( Shake.RuleResult k ~ v @@ -545,12 +556,11 @@ shakeOpen :: Recorder (WithPriority Log) -> IdeTesting -> WithHieDb -> IndexQueue - -> VFSHandle -> ShakeOptions -> Rules () -> IO IdeState shakeOpen recorder lspEnv defaultConfig logger debouncer - shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) withHieDb indexQueue vfs opts rules = mdo + shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) withHieDb indexQueue opts rules = mdo let log :: Logger.Priority -> Log -> IO () log = logWith recorder @@ -589,6 +599,8 @@ shakeOpen recorder lspEnv defaultConfig logger debouncer let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv dirtyKeys <- newTVarIO mempty + -- Take one VFS snapshot at the start + vfs <- atomically . newTVar =<< vfsSnapshot lspEnv pure ShakeExtras{..} (shakeDbM, shakeClose) <- shakeOpenDatabase @@ -740,6 +752,10 @@ newSession -> String -> IO ShakeSession newSession recorder extras@ShakeExtras{..} shakeDb acts reason = do + + -- Take a new VFS snapshot + atomically . writeTVar vfs =<< vfsSnapshot lspEnv + IdeOptions{optRunSubset} <- getIdeOptionsIO extras reenqueued <- atomicallyNamed "actionQueue - peek" $ peekInProgress actionQueue allPendingKeys <- @@ -1012,6 +1028,7 @@ usesWithStale key files = do -- whether the rule succeeded or not. mapM (lastValue key) files + data RuleBody k v = Rule (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v)) | RuleNoDiagnostics (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v)) @@ -1057,7 +1074,7 @@ defineEarlyCutOffNoFile recorder f = defineEarlyCutoff recorder $ RuleNoDiagnost fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" defineEarlyCutoff' - :: IdeRule k v + :: forall k v. IdeRule k v => ([FileDiagnostic] -> Action ()) -- ^ update diagnostics -- | compare current and previous for freshness -> (BS.ByteString -> BS.ByteString -> Bool) @@ -1088,24 +1105,26 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do res <- case val of Just res -> return res Nothing -> do + staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues state key file <&> \case + Nothing -> Failed False + Just (Succeeded ver v, _) -> Stale Nothing ver v + Just (Stale d ver v, _) -> Stale d ver v + Just (Failed b, _) -> Failed b + (bs, (diags, res)) <- actionCatch (do v <- action; liftIO $ evaluate $ force v) $ \(e :: SomeException) -> do pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) - modTime <- liftIO $ (currentValue . fst =<<) <$> atomicallyNamed "define - read 2" (getValues state GetModificationTime file) + + modTime <- case eqT @k @GetModificationTime of + Just Refl -> pure res + Nothing + | file == emptyFilePath -> pure Nothing + | otherwise -> liftIO $ (currentValue . fst =<<) <$> atomicallyNamed "define - read 2" (getValues state GetModificationTime file) + (bs, res) <- case res of - Nothing -> do - staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues state key file - pure $ case staleV of - Nothing -> (toShakeValue ShakeResult bs, Failed False) - Just v -> case v of - (Succeeded ver v, _) -> - (toShakeValue ShakeStale bs, Stale Nothing ver v) - (Stale d ver v, _) -> - (toShakeValue ShakeStale bs, Stale d ver v) - (Failed b, _) -> - (toShakeValue ShakeResult bs, Failed b) - Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v) + Nothing -> pure (toShakeValue ShakeStale bs, staleV) + Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded modTime v) liftIO $ atomicallyNamed "define - write" $ setValues state key file res (Vector.fromList diags) doDiagnostics diags let eq = case (bs, fmap decodeShakeValue old) of @@ -1273,7 +1292,7 @@ setStageDiagnostics -> STM [LSP.Diagnostic] setStageDiagnostics uri ver stage diags ds = updateSTMDiagnostics ds uri ver updatedDiags where - updatedDiags = Map.singleton (Just stage) (SL.toSortedList diags) + !updatedDiags = Map.singleton (Just stage) $! SL.toSortedList diags getAllDiagnostics :: STMDiagnosticStore -> @@ -1291,7 +1310,10 @@ updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} Versi -- Very important to use mapAccum here so that the tails of -- each mapping can be shared, otherwise quadratic space is -- used which is evident in long running sessions. - Map.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc))) + EM.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc))) zeroMapping - (Map.insert _version (shared_change, zeroMapping) mappingForUri) + (EM.insert actual_version (shared_change, zeroMapping) mappingForUri) shared_change = mkDelta changes + actual_version = case _version of + Nothing -> error "Nothing version from server" -- This is a violation of the spec + Just v -> v diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 9f16788c3b..f4c886e9b9 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -32,7 +32,6 @@ import UnliftIO.Concurrent import UnliftIO.Directory import UnliftIO.Exception -import Development.IDE.Core.FileStore hiding (Log) import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Tracing @@ -88,7 +87,7 @@ runLanguageServer -> config -> (config -> Value -> Either T.Text config) -> LSP.Handlers (ServerM config) - -> (LSP.LanguageContextEnv config -> VFSHandle -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) + -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) -> IO () runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigurationChange userHandlers getIdeState = do @@ -176,7 +175,7 @@ runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigur dbMVar <- newEmptyMVar ~(WithHieDbShield withHieDb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar - ide <- getIdeState env (makeLSPVFSHandle env) root withHieDb hieChan + ide <- getIdeState env root withHieDb hieChan let initConfig = parseConfiguration params diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 936a7f80e3..3152ce9ce4 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -36,8 +36,7 @@ import Development.IDE (Action, GhcVersion (..), hDuplicateTo') import Development.IDE.Core.Debouncer (Debouncer, newAsyncDebouncer) -import Development.IDE.Core.FileStore (isWatchSupported, - makeVFSHandle) +import Development.IDE.Core.FileStore (isWatchSupported) import Development.IDE.Core.IdeConfiguration (IdeConfiguration (..), registerIdeConfiguration) import Development.IDE.Core.OfInterest (FileOfInterestStatus (OnDisk), @@ -325,7 +324,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re t <- offsetTime log Info LogLspStart - runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath withHieDb hieChan -> do + runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env rootPath withHieDb hieChan -> do traverse_ IO.setCurrentDirectory rootPath t <- t log Info $ LogLspStartDuration t @@ -364,7 +363,6 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re logger debouncer options - vfs withHieDb hieChan dumpSTMStats @@ -392,7 +390,6 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1] when (n > 0) $ putStrLn $ " (" ++ intercalate ", " (catMaybes ucradles) ++ ")" putStrLn "\nStep 3/4: Initializing the IDE" - vfs <- makeVFSHandle sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader options = def_options @@ -400,7 +397,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) @@ -446,7 +443,6 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re root <- maybe IO.getCurrentDirectory return argsProjectRoot dbLoc <- getHieDbLoc root runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do - vfs <- makeVFSHandle sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader options = def_options @@ -454,7 +450,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide diff --git a/ghcide/src/Development/IDE/Types/Exports.hs b/ghcide/src/Development/IDE/Types/Exports.hs index becd09a6b2..539444a642 100644 --- a/ghcide/src/Development/IDE/Types/Exports.hs +++ b/ghcide/src/Development/IDE/Types/Exports.hs @@ -27,7 +27,6 @@ import Data.Text (Text, pack) import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util -import Development.IDE.Types.Shake (WithHieDb) import GHC.Generics (Generic) import HieDb @@ -156,6 +155,8 @@ createExportsMapTc modIface = do nonInternalModules :: ModuleName -> Bool nonInternalModules = not . (".Internal" `isSuffixOf`) . moduleNameString +type WithHieDb = forall a. (HieDb -> IO a) -> IO a + createExportsMapHieDb :: WithHieDb -> IO ExportsMap createExportsMapHieDb withHieDb = do mods <- withHieDb getAllIndexedMods diff --git a/ghcide/src/Development/IDE/Types/Shake.hs b/ghcide/src/Development/IDE/Types/Shake.hs index 32a9959991..dc58fd9d0b 100644 --- a/ghcide/src/Development/IDE/Types/Shake.hs +++ b/ghcide/src/Development/IDE/Types/Shake.hs @@ -38,14 +38,15 @@ import Type.Reflection (SomeTypeRep (SomeTypeRep) typeOf, typeRep, typeRepTyCon) import Unsafe.Coerce (unsafeCoerce) +import Development.IDE.Core.RuleTypes (FileVersion) -- | Intended to represent HieDb calls wrapped with (currently) retry -- functionality type WithHieDb = forall a. (HieDb -> IO a) -> IO a data Value v - = Succeeded TextDocumentVersion v - | Stale (Maybe PositionDelta) TextDocumentVersion v + = Succeeded (Maybe FileVersion) v + | Stale (Maybe PositionDelta) (Maybe FileVersion) v | Failed Bool -- True if we already tried the persistent rule deriving (Functor, Generic, Show) diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index be47ddf21b..4017a4b2c9 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -50,7 +50,7 @@ library , hslogger , lens , lens-aeson - , lsp ^>=1.4.0.0 + , lsp >=1.4.0.0 && < 1.6 , opentelemetry , optparse-applicative , process From cee793f579292d4c5a652cc5becb2cdf02ab93a6 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 26 Feb 2022 09:29:00 +0000 Subject: [PATCH 2/7] Fix hlint --- ghcide/.hlint.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/ghcide/.hlint.yaml b/ghcide/.hlint.yaml index 4aa51b68f4..e4ef9b0fe5 100644 --- a/ghcide/.hlint.yaml +++ b/ghcide/.hlint.yaml @@ -89,6 +89,7 @@ within: - Development.IDE.Compat - Development.IDE.Core.FileStore + - Development.IDE.Core.FileUtils - Development.IDE.Core.Compile - Development.IDE.Core.Rules - Development.IDE.Core.Tracing From 71da540f3d5bdf6ac5a36e83764218750f34563a Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 26 Feb 2022 09:44:44 +0000 Subject: [PATCH 3/7] fix doc --- ghcide/src/Development/IDE/Core/RuleTypes.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index ecece0cd9b..c6e9430cdb 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -290,10 +290,10 @@ pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True} -- | Get the modification time of a file. type instance RuleResult GetModificationTime = FileVersion --- | Either athe mtime from disk or an LSP version --- LSP versions always compare as greater than on disk versions +-- | Either the mtime from disk or an LSP version +-- LSP versions always compare as greater than on disk versions data FileVersion - = ModificationTime !POSIXTime + = ModificationTime !POSIXTime -- order of constructors is relevant | VFSVersion !Int32 deriving (Show, Generic, Eq, Ord) From c0a52a6ea81c275810fdd019f602fc9bfa8d5125 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 26 Feb 2022 09:45:29 +0000 Subject: [PATCH 4/7] format imports --- ghcide/src/Development/IDE/Core/Shake.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index beab767454..7bb211214d 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -154,11 +154,15 @@ import Data.Aeson (toJSON) import qualified Data.ByteString.Char8 as BS8 import Data.Coerce (coerce) import Data.Default +import Data.EnumMap.Strict (EnumMap) +import qualified Data.EnumMap.Strict as EM import Data.Foldable (for_, toList) +import Data.Functor ((<&>)) import Data.HashSet (HashSet) import qualified Data.HashSet as HSet import Data.String (fromString) import Debug.Trace.Flags (userTracingEnabled) +import Development.IDE.Core.FileUtils (getModTime) import qualified Development.IDE.Types.Exports as ExportsMap import qualified Focus import HieDb.Types @@ -167,10 +171,6 @@ import qualified Ide.PluginUtils as HLS import Ide.Types (PluginId) import qualified "list-t" ListT import qualified StmContainers.Map as STM -import Data.Functor ((<&>)) -import Development.IDE.Core.FileUtils (getModTime) -import Data.EnumMap.Strict (EnumMap) -import qualified Data.EnumMap.Strict as EM data Log = LogCreateHieDbExportsMapStart @@ -324,7 +324,7 @@ getVirtualFile nf = do -- Take a snapshot of the current LSP VFS vfsSnapshot :: Maybe (LSP.LanguageContextEnv a) -> IO VFS -vfsSnapshot Nothing = pure $ VFS mempty "" +vfsSnapshot Nothing = pure $ VFS mempty "" vfsSnapshot (Just lspEnv) = LSP.runLspT lspEnv $ LSP.getVirtualFiles @@ -1106,7 +1106,7 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do Just res -> return res Nothing -> do staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues state key file <&> \case - Nothing -> Failed False + Nothing -> Failed False Just (Succeeded ver v, _) -> Stale Nothing ver v Just (Stale d ver v, _) -> Stale d ver v Just (Failed b, _) -> Failed b @@ -1316,4 +1316,4 @@ updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} Versi shared_change = mkDelta changes actual_version = case _version of Nothing -> error "Nothing version from server" -- This is a violation of the spec - Just v -> v + Just v -> v From cc6fc510c924d2d98ab045561890bcf3695b9838 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 26 Feb 2022 09:50:14 +0000 Subject: [PATCH 5/7] format imports --- ghcide/src/Development/IDE/Core/Shake.hs | 56 ++++++++++++------------ 1 file changed, 27 insertions(+), 29 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 7bb211214d..49313a2bb5 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -82,21 +82,35 @@ module Development.IDE.Core.Shake( import Control.Concurrent.Async import Control.Concurrent.STM +import Control.Concurrent.STM.Stats (atomicallyNamed) import Control.Concurrent.Strict import Control.DeepSeq +import Control.Exception.Extra hiding (bracket_) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.Trans.Maybe +import Data.Aeson (toJSON) import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.Coerce (coerce) +import Data.Default import Data.Dynamic +import Data.EnumMap.Strict (EnumMap) +import qualified Data.EnumMap.Strict as EM +import Data.Foldable (for_, toList) +import Data.Functor ((<&>)) import qualified Data.HashMap.Strict as HMap +import Data.HashSet (HashSet) +import qualified Data.HashSet as HSet import Data.Hashable +import Data.IORef import Data.List.Extra (foldl', partition, takeEnd) import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.SortedList as SL +import Data.String (fromString) import qualified Data.Text as T import Data.Time import Data.Traversable @@ -105,7 +119,9 @@ import Data.Typeable import Data.Unique import Data.Vector (Vector) import qualified Data.Vector as Vector +import Debug.Trace.Flags (userTracingEnabled) import Development.IDE.Core.Debouncer +import Development.IDE.Core.FileUtils (getModTime) import Development.IDE.Core.PositionMapping import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes @@ -128,49 +144,31 @@ import Development.IDE.Graph.Rule import Development.IDE.Types.Action import Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports +import qualified Development.IDE.Types.Exports as ExportsMap import Development.IDE.Types.KnownTargets import Development.IDE.Types.Location import Development.IDE.Types.Logger hiding (Priority) import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options import Development.IDE.Types.Shake +import qualified Focus +import GHC.Fingerprint import GHC.Generics +import HieDb.Types +import Ide.Plugin.Config +import qualified Ide.PluginUtils as HLS +import Ide.Types (PluginId) import Language.LSP.Diagnostics import qualified Language.LSP.Server as LSP import Language.LSP.Types import qualified Language.LSP.Types as LSP -import Language.LSP.VFS -import System.FilePath hiding (makeRelative) -import System.Time.Extra - -import Data.IORef -import GHC.Fingerprint import Language.LSP.Types.Capabilities -import OpenTelemetry.Eventlog - -import Control.Concurrent.STM.Stats (atomicallyNamed) -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.EnumMap.Strict (EnumMap) -import qualified Data.EnumMap.Strict as EM -import Data.Foldable (for_, toList) -import Data.Functor ((<&>)) -import Data.HashSet (HashSet) -import qualified Data.HashSet as HSet -import Data.String (fromString) -import Debug.Trace.Flags (userTracingEnabled) -import Development.IDE.Core.FileUtils (getModTime) -import qualified Development.IDE.Types.Exports as ExportsMap -import qualified Focus -import HieDb.Types -import Ide.Plugin.Config -import qualified Ide.PluginUtils as HLS -import Ide.Types (PluginId) +import Language.LSP.VFS import qualified "list-t" ListT +import OpenTelemetry.Eventlog import qualified StmContainers.Map as STM +import System.FilePath hiding (makeRelative) +import System.Time.Extra data Log = LogCreateHieDbExportsMapStart From 64f83808d23c3436cffa68e60cfb5ff30a8aa487 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 26 Feb 2022 10:01:17 +0000 Subject: [PATCH 6/7] delay computation of staleV until it is needed --- ghcide/src/Development/IDE/Core/Shake.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 49313a2bb5..b3b0b9adde 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -1103,12 +1103,6 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do res <- case val of Just res -> return res Nothing -> do - staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues state key file <&> \case - Nothing -> Failed False - Just (Succeeded ver v, _) -> Stale Nothing ver v - Just (Stale d ver v, _) -> Stale d ver v - Just (Failed b, _) -> Failed b - (bs, (diags, res)) <- actionCatch (do v <- action; liftIO $ evaluate $ force v) $ \(e :: SomeException) -> do @@ -1121,7 +1115,13 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do | otherwise -> liftIO $ (currentValue . fst =<<) <$> atomicallyNamed "define - read 2" (getValues state GetModificationTime file) (bs, res) <- case res of - Nothing -> pure (toShakeValue ShakeStale bs, staleV) + Nothing -> do + staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues state key file <&> \case + Nothing -> Failed False + Just (Succeeded ver v, _) -> Stale Nothing ver v + Just (Stale d ver v, _) -> Stale d ver v + Just (Failed b, _) -> Failed b + pure (toShakeValue ShakeStale bs, staleV) Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded modTime v) liftIO $ atomicallyNamed "define - write" $ setValues state key file res (Vector.fromList diags) doDiagnostics diags From 036b303c033bae5a98abbfa6d0656c63f392f814 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 26 Feb 2022 10:08:50 +0000 Subject: [PATCH 7/7] Fix unrelated hlint --- ghcide/.hlint.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/ghcide/.hlint.yaml b/ghcide/.hlint.yaml index e4ef9b0fe5..590a707570 100644 --- a/ghcide/.hlint.yaml +++ b/ghcide/.hlint.yaml @@ -105,6 +105,7 @@ - Development.IDE.GHC.Compat.Units - Development.IDE.GHC.Compat.Util - Development.IDE.GHC.CPP + - Development.IDE.GHC.Dump - Development.IDE.GHC.ExactPrint - Development.IDE.GHC.Orphans - Development.IDE.GHC.Util