Avoid always rerunning GetModificationTime for interface files too

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

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

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,18 @@ 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", ".hi-boot"]
+
+-- | Reset the GetModificationTime state of interface files
+resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> IO ()
+resetInterfaceStore state f = do
+    deleteValue state (GetModificationTime_ True) f
+    deleteValue state (GetModificationTime_ False) f
+
 -- | Reset the GetModificationTime state of watched files
 resetFileStore :: IdeState -> [FileEvent] -> IO ()
 resetFileStore ideState changes = mask $ \_ ->
@@ -134,8 +149,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

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 $ toNormalizedFilePath' targetPath
+        writeHiFile hsc hiFile
+
 -- | A rule that wires per-file rules together
 mainRule :: Rules ()
 mainRule = do

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.

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