Populate ms_hs_date in GetModSummary rule

src/Development/IDE/Core/Compile.hs

@@ -85,6 +85,7 @@ import Control.DeepSeq (rnf)
 import Control.Exception (evaluate)
 import Exception (ExceptionMonad)
 import TcEnv (tcLookup)
+import Data.Time (UTCTime)
 
 
 -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
@@ -93,13 +94,14 @@ parseModule
     -> HscEnv
     -> [PackageName]
     -> FilePath
+    -> UTCTime
     -> Maybe SB.StringBuffer
     -> IO (IdeResult (StringBuffer, ParsedModule))
-parseModule IdeOptions{..} env comp_pkgs filename mbContents =
+parseModule IdeOptions{..} env comp_pkgs filename modTime mbContents =
     fmap (either (, Nothing) id) $
     evalGhcEnv env $ runExceptT $ do
         (contents, dflags) <- preprocessor filename mbContents
-        (diag, modu) <- parseFileContents optPreprocessor dflags comp_pkgs filename contents
+        (diag, modu) <- parseFileContents optPreprocessor dflags comp_pkgs filename modTime contents
         return (diag, Just (contents, modu))
 
 
@@ -409,23 +411,20 @@ getImportsParsed dflags (L loc parsed) = do
 getModSummaryFromBuffer
     :: GhcMonad m
     => FilePath
+    -> UTCTime
     -> DynFlags
     -> GHC.ParsedSource
     -> StringBuffer
     -> ExceptT [FileDiagnostic] m ModSummary
-getModSummaryFromBuffer fp dflags parsed contents = do
+getModSummaryFromBuffer fp modTime dflags parsed contents = do
   (modName, imports) <- liftEither $ getImportsParsed dflags parsed
 
   modLoc <- liftIO $ mkHomeModLocation dflags modName fp
   let InstalledUnitId unitId = thisInstalledUnitId dflags
   return $ ModSummary
     { ms_mod          = mkModule (fsToUnitId unitId) modName
     , ms_location     = modLoc
-    , ms_hs_date      = error "Rules should not depend on ms_hs_date"
-        -- When we are working with a virtual file we do not have a file date.
-        -- To avoid silent issues where something is not processed because the date
-        -- has not changed, we make sure that things blow up if they depend on the
-        -- date.
+    , ms_hs_date      = modTime
     , ms_textual_imps = [imp | (False, imp) <- imports]
     , ms_hspp_file    = fp
     , ms_hspp_opts    = dflags
@@ -455,9 +454,10 @@ getModSummaryFromBuffer fp dflags parsed contents = do
 getModSummaryFromImports
   :: (HasDynFlags m, ExceptionMonad m, MonadIO m)
   => FilePath
+  -> UTCTime
   -> Maybe SB.StringBuffer
   -> ExceptT [FileDiagnostic] m ModSummary
-getModSummaryFromImports fp contents = do
+getModSummaryFromImports fp modTime contents = do
     (contents, dflags) <- preprocessor fp contents
     (srcImports, textualImports, L _ moduleName) <-
         ExceptT $ liftIO $ first (diagFromErrMsgs "parser" dflags) <$> GHC.getHeaderImports dflags contents fp fp
@@ -476,10 +476,7 @@ getModSummaryFromImports fp contents = do
 #if MIN_GHC_API_VERSION(8,8,0)
                 , ms_hie_date     = Nothing
 #endif
-                , ms_hs_date      = error "Rules should not depend on ms_hs_date"
-        -- When we are working with a virtual file we do not have a file date.
-        -- To avoid silent issues where something is not processed because the date
-        -- has not changed, we make sure that things blow up if they depend on the date.
+                , ms_hs_date      = modTime
                 , ms_hsc_src      = sourceType
                 -- The contents are used by the GetModSummary rule
                 , ms_hspp_buf     = Just contents
@@ -536,9 +533,10 @@ parseFileContents
        -> DynFlags -- ^ flags to use
        -> [PackageName] -- ^ The package imports to ignore
        -> FilePath  -- ^ the filename (for source locations)
+       -> UTCTime   -- ^ the modification timestamp
        -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
        -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
-parseFileContents customPreprocessor dflags comp_pkgs filename contents = do
+parseFileContents customPreprocessor dflags comp_pkgs filename modTime contents = do
    let loc  = mkRealSrcLoc (mkFastString filename) 1 1
    case unP Parser.parseModule (mkPState dflags contents loc) of
 #if MIN_GHC_API_VERSION(8,10,0)
@@ -572,7 +570,7 @@ parseFileContents customPreprocessor dflags comp_pkgs filename contents = do
                unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs
                let parsed' = removePackageImports comp_pkgs parsed
                let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns
-               ms <- getModSummaryFromBuffer filename dflags parsed' contents
+               ms <- getModSummaryFromBuffer filename modTime dflags parsed' contents
                let pm =
                      ParsedModule {
                          pm_mod_summary = ms

src/Development/IDE/Core/FileStore.hs

@@ -10,6 +10,7 @@ module Development.IDE.Core.FileStore(
     setFileModified,
     setSomethingModified,
     fileStoreRules,
+    modificationTime,
     VFSHandle,
     makeVFSHandle,
     makeLSPVFSHandle
@@ -27,6 +28,8 @@ import           Development.Shake.Classes
 import           Control.Exception
 import           GHC.Generics
 import Data.Either.Extra
+import Data.Int (Int64)
+import Data.Time
 import System.IO.Error
 import qualified Data.ByteString.Char8 as BS
 import Development.IDE.Types.Diagnostics
@@ -36,9 +39,9 @@ import Development.IDE.Core.RuleTypes
 import qualified Data.Rope.UTF16 as Rope
 
 #ifdef mingw32_HOST_OS
-import Data.Time
 import qualified System.Directory as Dir
 #else
+import Data.Time.Clock.System (systemToUTCTime, SystemTime(MkSystemTime))
 import Foreign.Ptr
 import Foreign.C.String
 import Foreign.C.Types
@@ -124,7 +127,7 @@ getModificationTimeRule vfs =
     -- 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 (Int,Int)
+    getModTime :: FilePath -> IO (Int64, Int64)
     getModTime f =
 #ifdef mingw32_HOST_OS
         do time <- Dir.getModificationTime f
@@ -136,15 +139,24 @@ getModificationTimeRule vfs =
         alloca $ \secPtr ->
         alloca $ \nsecPtr -> do
             Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr
-            sec <- peek secPtr
-            nsec <- peek nsecPtr
-            pure (fromEnum sec, fromIntegral nsec)
+            CTime sec <- peek secPtr
+            CLong nsec <- peek nsecPtr
+            pure (sec, nsec)
 
 -- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow
 -- as doing the FFI call ourselves :(.
 foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int
 #endif
 
+modificationTime :: FileVersion -> Maybe UTCTime
+modificationTime VFSVersion{} = Nothing
+modificationTime (ModificationTime large small) =
+#ifdef mingw32_HOST_OS
+    Just (UTCTime (ModifiedJulianDay $ fromIntegral large) (picosecondsToDiffTime $ fromIntegral small))
+#else
+    Just (systemToUTCTime $ MkSystemTime large (fromIntegral small))
+#endif
+
 getFileContentsRule :: VFSHandle -> Rules ()
 getFileContentsRule vfs =
     define $ \GetFileContents file -> do
@@ -163,9 +175,13 @@ ideTryIOException fp act =
       (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e)
       <$> try act
 
-
-getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe T.Text)
-getFileContents = use_ GetFileContents
+-- | Returns the modification time and the contents.
+--   For VFS paths, the modification time is the current time.
+getFileContents :: NormalizedFilePath -> Action (UTCTime, Maybe T.Text)
+getFileContents f = do
+    (fv, txt) <- use_ GetFileContents f
+    modTime <- maybe (liftIO getCurrentTime) return $ modificationTime fv
+    return (modTime, txt)
 
 fileStoreRules :: VFSHandle -> Rules ()
 fileStoreRules vfs = do

src/Development/IDE/Core/RuleTypes.hs

@@ -123,6 +123,10 @@ type instance RuleResult IsFileOfInterest = Bool
 -- without needing to parse the entire source
 type instance RuleResult GetModSummary = ModSummary
 
+-- | Generate a ModSummary with the timestamps elided,
+--   for more successful early cutoff
+type instance RuleResult GetModSummaryWithoutTimestamps = ModSummary
+
 data GetParsedModule = GetParsedModule
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GetParsedModule
@@ -206,6 +210,12 @@ instance Hashable IsFileOfInterest
 instance NFData   IsFileOfInterest
 instance Binary   IsFileOfInterest
 
+data GetModSummaryWithoutTimestamps = GetModSummaryWithoutTimestamps
+    deriving (Eq, Show, Typeable, Generic)
+instance Hashable GetModSummaryWithoutTimestamps
+instance NFData   GetModSummaryWithoutTimestamps
+instance Binary   GetModSummaryWithoutTimestamps
+
 data GetModSummary = GetModSummary
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GetModSummary

src/Development/IDE/Core/Rules.hs

@@ -43,7 +43,7 @@ import Development.IDE.Spans.Calculate
 import Development.IDE.Import.DependencyInformation
 import Development.IDE.Import.FindImports
 import           Development.IDE.Core.FileExists
-import           Development.IDE.Core.FileStore        (getFileContents)
+import           Development.IDE.Core.FileStore        (modificationTime, getFileContents)
 import           Development.IDE.Types.Diagnostics as Diag
 import Development.IDE.Types.Location
 import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)
@@ -86,6 +86,7 @@ import Control.Exception
 import Control.Monad.State
 import FastString (FastString(uniq))
 import qualified HeaderInfo as Hdr
+import Data.Time (UTCTime(..))
 
 -- | This is useful for rules to convert rules that can only produce errors or
 -- a result into the more general IdeResult type that supports producing
@@ -165,7 +166,7 @@ getHieFile ide file mod = do
 
 getHomeHieFile :: NormalizedFilePath -> MaybeT IdeAction HieFile
 getHomeHieFile f = do
-  ms <- fst <$> useE GetModSummary f
+  ms <- fst <$> useE GetModSummaryWithoutTimestamps f
   let normal_hie_f = toNormalizedFilePath' hie_f
       hie_f = ml_hie_file $ ms_location ms
 
@@ -238,10 +239,10 @@ getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do
         -- parsed module
         comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess)
     opt <- getIdeOptions
-    (_, contents) <- getFileContents file
+    (modTime, contents) <- getFileContents file
 
     let dflags    = hsc_dflags hsc
-        mainParse = getParsedModuleDefinition hsc opt comp_pkgs file contents
+        mainParse = getParsedModuleDefinition hsc opt comp_pkgs file modTime contents
 
     -- Parse again (if necessary) to capture Haddock parse errors
     if gopt Opt_Haddock dflags
@@ -250,7 +251,7 @@ getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do
         else do
             let haddockParse = do
                     (_, (!diagsHaddock, _)) <-
-                        getParsedModuleDefinition (withOptHaddock hsc) opt comp_pkgs file contents
+                        getParsedModuleDefinition (withOptHaddock hsc) opt comp_pkgs file modTime contents
                     return diagsHaddock
 
             ((fingerPrint, (diags, res)), diagsHaddock) <-
@@ -279,9 +280,11 @@ mergeParseErrorsHaddock normal haddock = normal ++
                  | otherwise = "Haddock: " <> x
 
 
-getParsedModuleDefinition :: HscEnv -> IdeOptions -> [PackageName] -> NormalizedFilePath -> Maybe T.Text -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule))
-getParsedModuleDefinition packageState opt comp_pkgs file contents = do
-    (diag, res) <- parseModule opt packageState comp_pkgs (fromNormalizedFilePath file) (fmap textToStringBuffer contents)
+getParsedModuleDefinition :: HscEnv -> IdeOptions -> [PackageName] -> NormalizedFilePath -> UTCTime -> Maybe T.Text -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule))
+getParsedModuleDefinition packageState opt comp_pkgs file modTime contents = do
+    let fp = fromNormalizedFilePath file
+        buffer = textToStringBuffer <$> contents
+    (diag, res) <- parseModule opt packageState comp_pkgs fp modTime buffer
     case res of
         Nothing -> pure (Nothing, (diag, Nothing))
         Just (contents, modu) -> do
@@ -293,7 +296,7 @@ getParsedModuleDefinition packageState opt comp_pkgs file contents = do
 getLocatedImportsRule :: Rules ()
 getLocatedImportsRule =
     define $ \GetLocatedImports file -> do
-        ms <- use_ GetModSummary file
+        ms <- use_ GetModSummaryWithoutTimestamps file
         let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]
         env_eq <- use_ GhcSession file
         let env = hscEnv env_eq
@@ -339,7 +342,7 @@ rawDependencyInformation fs = do
       -- If we have, just return its Id but don't update any of the state.
       -- Otherwise, we need to process its imports.
       checkAlreadyProcessed f $ do
-          al <- lift $ modSummaryToArtifactsLocation f <$> use_ GetModSummary f
+          al <- lift $ modSummaryToArtifactsLocation f <$> use_ GetModSummaryWithoutTimestamps f
           -- Get a fresh FilePathId for the new file
           fId <- getFreshFid al
           -- Adding an edge to the bootmap so we can make sure to
@@ -450,7 +453,7 @@ reportImportCyclesRule =
             where loc = srcSpanToLocation (getLoc imp)
                   fp = toNormalizedFilePath' $ srcSpanToFilename (getLoc imp)
           getModuleName file = do
-           ms <- use_ GetModSummary file
+           ms <- use_ GetModSummaryWithoutTimestamps file
            pure (moduleNameString . moduleName . ms_mod $ ms)
           showCycle mods  = T.intercalate ", " (map T.pack mods)
 
@@ -608,7 +611,7 @@ loadGhcSession = do
 ghcSessionDepsDefinition :: NormalizedFilePath -> Action (IdeResult HscEnvEq)
 ghcSessionDepsDefinition file = do
         hsc <- hscEnv <$> use_ GhcSession file
-        (ms,_) <- useWithStale_ GetModSummary file
+        (ms,_) <- useWithStale_ GetModSummaryWithoutTimestamps file
         (deps,_) <- useWithStale_ GetDependencies file
         let tdeps = transitiveModuleDeps deps
         ifaces <- uses_ GetModIface tdeps
@@ -657,7 +660,7 @@ getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do
 
 isHiFileStableRule :: Rules ()
 isHiFileStableRule = define $ \IsHiFileStable f -> do
-    ms <- use_ GetModSummary f
+    ms <- use_ GetModSummaryWithoutTimestamps f
     let hiFile = toNormalizedFilePath'
                 $ case ms_hsc_src ms of
                     HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)
@@ -679,15 +682,29 @@ isHiFileStableRule = define $ \IsHiFileStable f -> do
     return ([], Just sourceModified)
 
 getModSummaryRule :: Rules ()
-getModSummaryRule = defineEarlyCutoff $ \GetModSummary f -> do
-    dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f
-    (_, mFileContent) <- getFileContents f
-    modS <- liftIO $ evalWithDynFlags dflags $ runExceptT $
-        getModSummaryFromImports (fromNormalizedFilePath f) (textToStringBuffer <$> mFileContent)
-    case modS of
-        Right ms -> do
-            return ( Just (computeFingerprint f dflags ms), ([], Just ms))
-        Left diags -> return (Nothing, (diags, Nothing))
+getModSummaryRule = do
+    defineEarlyCutoff $ \GetModSummary f -> do
+        dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f
+        (modTime, mFileContent) <- getFileContents f
+        let fp = fromNormalizedFilePath f
+        modS <- liftIO $ evalWithDynFlags dflags $ runExceptT $
+                getModSummaryFromImports fp modTime (textToStringBuffer <$> mFileContent)
+        case modS of
+            Right ms -> do
+                let fingerPrint = hash (computeFingerprint f dflags ms, hashUTC modTime)
+                return ( Just (BS.pack $ show fingerPrint) , ([], Just ms))
+            Left diags -> return (Nothing, (diags, Nothing))
+
+    defineEarlyCutoff $ \GetModSummaryWithoutTimestamps f -> do
+        ms <- use GetModSummary f
+        case ms of
+            Just msWithTimestamps -> do
+                let ms = msWithTimestamps { ms_hs_date = error "use GetModSummary instead of GetModSummaryWithoutTimestamps" }
+                dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f
+                -- include the mod time in the fingerprint
+                let fp = BS.pack $ show $ hash (computeFingerprint f dflags ms)
+                return (Just fp, ([], Just ms))
+            Nothing -> return (Nothing, ([], Nothing))
     where
         -- Compute a fingerprint from the contents of `ModSummary`,
         -- eliding the timestamps and other non relevant fields.
@@ -702,8 +719,9 @@ getModSummaryRule = defineEarlyCutoff $ \GetModSummary f -> do
                     )
                 fingerPrintImports = map (fmap uniq *** (moduleNameString . unLoc))
                 opts = Hdr.getOptions dflags (fromJust ms_hspp_buf) (fromNormalizedFilePath f)
-                fp = hash fingerPrint
-            in BS.pack (show fp)
+            in fingerPrint
+
+        hashUTC UTCTime{..} = (fromEnum utctDay, fromEnum utctDayTime)
 
 getModIfaceRule :: Rules ()
 getModIfaceRule = defineEarlyCutoff $ \GetModIface f -> do
@@ -734,14 +752,15 @@ regenerateHiFile sess f = do
         -- these packages as we have already dealt with what they map to.
         comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess)
     opt <- getIdeOptions
-    (_, contents) <- getFileContents f
-    -- Embed --haddocks in the interface file
-    (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition (withOptHaddock hsc) opt comp_pkgs f contents
+    (modTime, contents) <- getFileContents f
+
+    -- Embed haddocks in the interface file
+    (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition (withOptHaddock hsc) opt comp_pkgs f modTime contents
     (diags, mb_pm) <- case mb_pm of
         Just _ -> return (diags, mb_pm)
         Nothing -> do
             -- if parsing fails, try parsing again with Haddock turned off
-            (_, (diagsNoHaddock, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt comp_pkgs f contents
+            (_, (diagsNoHaddock, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt comp_pkgs f modTime contents
             return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm)
     case mb_pm of
         Nothing -> return (diags, Nothing)