From df6f528c90839aac883a2013e49217eb800e3a85 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Tue, 2 Mar 2021 21:49:51 +0000 Subject: [PATCH 1/4] Extend file watching to interfaces --- ghcide/src/Development/IDE/Core/FileExists.hs | 2 +- ghcide/src/Development/IDE/Core/FileStore.hs | 24 +++++++++++++++---- ghcide/src/Development/IDE/Core/Rules.hs | 14 ++++++++--- ghcide/src/Development/IDE/Core/Shake.hs | 4 ++-- 4 files changed, 34 insertions(+), 10 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index 19ebf74904..13e094d9be 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -103,7 +103,7 @@ modifyFileExists state changes = do modifyVar_ var $ evaluate . HashMap.union changesMap -- See Note [Invalidating file existence results] -- flush previous values - mapM_ (deleteValue state GetFileExists) (HashMap.keys changesMap) + mapM_ (deleteValue (shakeExtras state) GetFileExists) (HashMap.keys changesMap) fromChange :: FileChangeType -> Maybe Bool fromChange FcCreated = Just True diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index a05210bdf2..74e6cd3bcf 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -15,7 +15,9 @@ module Development.IDE.Core.FileStore( makeVFSHandle, makeLSPVFSHandle, isFileOfInterestRule - ,resetFileStore) where + ,resetFileStore + ,resetInterfaceStore + ) where import Control.Concurrent.Extra import Control.Concurrent.STM (atomically) @@ -67,6 +69,7 @@ import Language.LSP.Types (FileChangeType (F FileEvent (FileEvent), uriToFilePath, toNormalizedFilePath) import Language.LSP.VFS +import System.FilePath makeVFSHandle :: IO VFSHandle makeVFSHandle = do @@ -111,7 +114,7 @@ getModificationTimeRule vfs isWatched = pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver)) Nothing -> do isWF <- isWatched file - unless isWF alwaysRerun + unless (isWF || isInterface file) alwaysRerun liftIO $ fmap wrap (getModTime file') `catch` \(e :: IOException) -> do let err | isDoesNotExistError e = "File does not exist: " ++ file' @@ -121,6 +124,19 @@ getModificationTimeRule vfs isWatched = then return (Nothing, ([], Nothing)) else return (Nothing, ([diag], Nothing)) +-- | Interface files cannot be watched, since they live outside the workspace. +-- But interface files are private, in that only HLS writes them. +-- So we implement watching ourselves, and bypass the need for alwaysRerun. +isInterface :: NormalizedFilePath -> Bool +isInterface f = takeExtension (fromNormalizedFilePath f) `elem` [".hi", ".hie"] + +-- | Reset the GetModificationTime state of interface files +resetInterfaceStore :: ShakeExtras -> FilePath -> IO () +resetInterfaceStore state f = do + forM_ [toNormalizedFilePath' (replaceExtension f ext) | ext <- ["hi","hie"]] $ \f -> + forM_ [True,False] $ \gmt -> + deleteValue state (GetModificationTime_ gmt) f + -- | Reset the GetModificationTime state of watched files resetFileStore :: IdeState -> [FileEvent] -> IO () resetFileStore ideState changes = mask $ \_ -> @@ -134,8 +150,8 @@ resetFileStore ideState changes = mask $ \_ -> OfInterestVar foisVar <- getIdeGlobalExtras (shakeExtras ideState) fois <- readVar foisVar unless (HM.member (toNormalizedFilePath f) fois) $ do - deleteValue ideState (GetModificationTime_ True) (toNormalizedFilePath' f) - deleteValue ideState (GetModificationTime_ False) (toNormalizedFilePath' f) + deleteValue (shakeExtras ideState) (GetModificationTime_ True) (toNormalizedFilePath' f) + deleteValue (shakeExtras ideState) (GetModificationTime_ False) (toNormalizedFilePath' f) _ -> pure () -- Dir.getModificationTime is surprisingly slow since it performs diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index adeb4b473b..bc31326fac 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -86,7 +86,7 @@ import Data.Tuple.Extra import Development.IDE.Core.Compile import Development.IDE.Core.FileExists import Development.IDE.Core.FileStore (getFileContents, - modificationTime) + modificationTime, resetInterfaceStore) import Development.IDE.Core.OfInterest import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes @@ -922,7 +922,7 @@ getModIfaceRule = defineEarlyCutoff $ \GetModIface f -> do hiDiags <- case hiFile of Just hiFile | OnDisk <- status - , not (tmrDeferedError tmr) -> liftIO $ writeHiFile hsc hiFile + , not (tmrDeferedError tmr) -> writeHiFileAction hsc hiFile _ -> pure [] return (fp, (diags++hiDiags, hiFile)) NotFOI -> do @@ -991,7 +991,7 @@ regenerateHiFile sess f ms compNeeded = do -- We don't write the `.hi` file if there are defered errors, since we won't get -- accurate diagnostics next time if we do hiDiags <- if not $ tmrDeferedError tmr - then liftIO $ writeHiFile hsc hiFile + then writeHiFileAction hsc hiFile else pure [] pure (hiDiags <> gDiags <> concat wDiags) @@ -1090,6 +1090,14 @@ needsCompilationRule = defineEarlyCutoff $ \NeedsCompilation file -> do newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) } instance IsIdeGlobal CompiledLinkables +writeHiFileAction :: HscEnv -> HiFileResult -> Action [FileDiagnostic] +writeHiFileAction hsc hiFile = do + extras <- getShakeExtras + let targetPath = ml_hi_file $ ms_location $ hirModSummary hiFile + liftIO $ do + resetInterfaceStore extras targetPath + writeHiFile hsc hiFile + -- | A rule that wires per-file rules together mainRule :: Rules () mainRule = do diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index a9c190ed1e..208293310d 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -420,11 +420,11 @@ setValues state key file val diags = modifyVar_ state $ \vals -> do -- | Delete the value stored for a given ide build key deleteValue :: (Typeable k, Hashable k, Eq k, Show k) - => IdeState + => ShakeExtras -> k -> NormalizedFilePath -> IO () -deleteValue IdeState{shakeExtras = ShakeExtras{state}} key file = modifyVar_ state $ \vals -> +deleteValue ShakeExtras{state} key file = modifyVar_ state $ \vals -> evaluate $ HMap.delete (file, Key key) vals -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value. From 0e71043f65df176f241fe042c3639f9ac4f1f3aa Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 6 Mar 2021 13:17:51 +0000 Subject: [PATCH 2/4] Close Shake session before exit in order to dump Shake profile --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index a40715bcc1..df9c12264b 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -200,7 +200,11 @@ cancelHandler cancelRequest = LSP.notificationHandler SCancelRequest $ \Notifica liftIO $ cancelRequest (SomeLspId _id) exitHandler :: IO () -> LSP.Handlers (ServerM c) -exitHandler exit = LSP.notificationHandler SExit (const $ liftIO exit) +exitHandler exit = LSP.notificationHandler SExit $ const $ do + (_, ide) <- ask + -- flush out the Shake session to record a Shake profile if applicable + liftIO $ restartShakeSession (shakeExtras ide) [] + liftIO exit modifyOptions :: LSP.Options -> LSP.Options modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS From 40e68d2d3eb3963cd3346be5371c0c247d75dca9 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 7 Mar 2021 13:25:33 +0000 Subject: [PATCH 3/4] Update isInterface and resetInterfaceStore with @wz1000 feedback --- ghcide/src/Development/IDE/Core/FileStore.hs | 9 ++++----- ghcide/src/Development/IDE/Core/Rules.hs | 2 +- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 74e6cd3bcf..8637dc489d 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -128,14 +128,13 @@ getModificationTimeRule vfs isWatched = -- But interface files are private, in that only HLS writes them. -- So we implement watching ourselves, and bypass the need for alwaysRerun. isInterface :: NormalizedFilePath -> Bool -isInterface f = takeExtension (fromNormalizedFilePath f) `elem` [".hi", ".hie"] +isInterface f = takeExtension (fromNormalizedFilePath f) `elem` [".hi", ".hi-boot"] -- | Reset the GetModificationTime state of interface files -resetInterfaceStore :: ShakeExtras -> FilePath -> IO () +resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> IO () resetInterfaceStore state f = do - forM_ [toNormalizedFilePath' (replaceExtension f ext) | ext <- ["hi","hie"]] $ \f -> - forM_ [True,False] $ \gmt -> - deleteValue state (GetModificationTime_ gmt) f + deleteValue state (GetModificationTime_ True) f + deleteValue state (GetModificationTime_ False) f -- | Reset the GetModificationTime state of watched files resetFileStore :: IdeState -> [FileEvent] -> IO () diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index bc31326fac..933a3ed9b2 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -1095,7 +1095,7 @@ writeHiFileAction hsc hiFile = do extras <- getShakeExtras let targetPath = ml_hi_file $ ms_location $ hirModSummary hiFile liftIO $ do - resetInterfaceStore extras targetPath + resetInterfaceStore extras $ toNormalizedFilePath' targetPath writeHiFile hsc hiFile -- | A rule that wires per-file rules together From d3ed333f069c87f6b652df61ddfc381710a262b0 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 7 Mar 2021 13:26:10 +0000 Subject: [PATCH 4/4] remove redundant imports --- ghcide/src/Development/IDE/Core/Compile.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index d016849953..55c0cc6c65 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -115,15 +115,12 @@ import Control.Concurrent.STM hiding (orElse) import Data.Aeson (toJSON) import Data.Binary import Data.Binary.Put -import Data.Bits (shiftR) import qualified Data.ByteString.Lazy as LBS import Data.Coerce import Data.Functor import qualified Data.HashMap.Strict as HashMap import Data.Tuple.Extra (dupe) import Data.Unique -import Data.Word -import Foreign.Marshal.Array (withArrayLen) import GHC.Fingerprint import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP