More ModSummary timestamps

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,22 +411,19 @@ getImportsParsed dflags (L loc parsed) = do
 getModSummaryFromBuffer
     :: GhcMonad m
     => FilePath
+    -> UTCTime
     -> DynFlags
     -> GHC.ParsedSource
     -> ExceptT [FileDiagnostic] m ModSummary
-getModSummaryFromBuffer fp dflags parsed = do
+getModSummaryFromBuffer fp modTime dflags parsed = 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
@@ -448,9 +447,10 @@ getModSummaryFromBuffer fp dflags parsed = 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
@@ -469,7 +469,7 @@ getModSummaryFromImports fp contents = do
 #if MIN_GHC_API_VERSION(8,8,0)
                 , ms_hie_date     = Nothing
 #endif
-                , ms_hs_date      = error "use GetModSummary instead of GetModSummaryWithoutTimestamps"
+                , ms_hs_date      = modTime
                 , ms_hsc_src      = sourceType
                 -- The contents are used by the GetModSummary rule
                 , ms_hspp_buf     = Just contents
@@ -526,9 +526,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)
@@ -562,7 +563,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'
+               ms <- getModSummaryFromBuffer filename modTime dflags parsed'
                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 large) (picosecondsToDiffTime small))
+#else
+    Just (systemToUTCTime $ MkSystemTime large (fromIntegral small))
+#endif
+
 getFileContentsRule :: VFSHandle -> Rules ()
 getFileContentsRule vfs =
     define $ \GetFileContents file -> do

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)
@@ -239,10 +239,11 @@ getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do
         -- parsed module
         comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess)
     opt <- getIdeOptions
-    (_, contents) <- getFileContents file
+    (fv, contents) <- getFileContents file
+    modTime <- maybe (liftIO getCurrentTime) return $ modificationTime fv
 
     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
@@ -251,7 +252,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) <-
@@ -280,9 +281,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
@@ -609,9 +612,7 @@ loadGhcSession = do
 ghcSessionDepsDefinition :: NormalizedFilePath -> Action (IdeResult HscEnvEq)
 ghcSessionDepsDefinition file = do
         hsc <- hscEnv <$> use_ GhcSession file
-        -- We do want the timestamps in the ModSummary for the interactive evaluation functions
-        -- (e.g. in the Eval plugin)
-        (ms,_) <- useWithStale_ GetModSummary file
+        (ms,_) <- useWithStale_ GetModSummaryWithoutTimestamps file
         (deps,_) <- useWithStale_ GetDependencies file
         let tdeps = transitiveModuleDeps deps
         ifaces <- uses_ GetModIface tdeps
@@ -645,7 +646,9 @@ ghcSessionDepsDefinition file = do
 
 getModIfaceFromDiskRule :: Rules ()
 getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do
-  ms <- use_ GetModSummaryWithoutTimestamps f
+    -- We do want the timestamps in the ModSummary for the interactive evaluation functions
+    -- (e.g. in the Eval plugin)
+  ms <- use_ GetModSummary f
   (diags_session, mb_session) <- ghcSessionDepsDefinition f
   case mb_session of
       Nothing -> return (Nothing, (diags_session, Nothing))
@@ -683,38 +686,27 @@ isHiFileStableRule = define $ \IsHiFileStable f -> do
 
 getModSummaryRule :: Rules ()
 getModSummaryRule = do
-    defineEarlyCutoff $ \GetModSummaryWithoutTimestamps f -> do
+    defineEarlyCutoff $ \GetModSummary f -> do
         dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f
-        (_, mFileContent) <- getFileContents f
+        (fv, mFileContent) <- getFileContents f
+        modTime <- maybe (liftIO getCurrentTime) return $ modificationTime fv
         let fp = fromNormalizedFilePath f
         modS <- liftIO $ evalWithDynFlags dflags $ runExceptT $
-                getModSummaryFromImports fp (textToStringBuffer <$> mFileContent)
+                getModSummaryFromImports fp modTime (textToStringBuffer <$> mFileContent)
         case modS of
             Right ms -> do
-                let fingerPrint = hash (computeFingerprint f dflags ms)
+                let fingerPrint = hash (computeFingerprint f dflags ms, hashUTC modTime)
                 return ( Just (BS.pack $ show fingerPrint) , ([], Just ms))
             Left diags -> return (Nothing, (diags, Nothing))
 
-    defineEarlyCutoff $ \GetModSummary f -> do
-        ms <- use GetModSummaryWithoutTimestamps f
+    defineEarlyCutoff $ \GetModSummaryWithoutTimestamps f -> do
+        ms <- use GetModSummary f
         case ms of
-            Just msWithoutTimestamps -> do
-                isFileOfInterest <- use_ IsFileOfInterest f
-                let fp = fromNormalizedFilePath f
-                -- Get the modification time from the file system instead of Shake
-                --   * For non vfs this is correct, the 'FileVersion' times stored by Shake are opaque anyway
-                --   * For vfs the modification time is assumed to be the current time
-                fileModTime <- liftIO $ if isFileOfInterest
-                    then getCurrentTime
-                    else getModificationTime fp
-                let ms = msWithoutTimestamps
-                        { ms_hie_date = Nothing
-                        , ms_hs_date = fileModTime
-                        , ms_iface_date = Nothing
-                        }
+            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, hashUTC fileModTime)
+                let fp = BS.pack $ show $ hash (computeFingerprint f dflags ms)
                 return (Just fp, ([], Just ms))
             Nothing -> return (Nothing, ([], Nothing))
     where
@@ -764,14 +756,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
+    (fv, contents) <- getFileContents f
+    modTime <- maybe (liftIO getCurrentTime) return $ modificationTime fv
     -- Embed --haddocks in the interface file
-    (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition (withOptHaddock hsc) opt comp_pkgs f contents
+    (_, (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)

src/Development/IDE/Core/Shake.hs

@@ -48,7 +48,7 @@ module Development.IDE.Core.Shake(
     sendEvent,
     ideLogger,
     actionLogger,
-    FileVersion(..), modificationTime,
+    FileVersion(..),
     Priority(..),
     updatePositionMapping,
     deleteValue,
@@ -114,6 +114,7 @@ import Data.IORef
 import NameCache
 import UniqSupply
 import PrelInfo
+import Data.Int (Int64)
 
 -- information we stash inside the shakeExtra field
 data ShakeExtras = ShakeExtras
@@ -632,7 +633,7 @@ newSession ShakeExtras{..} shakeDb systemActs userActs = do
 instantiateDelayedAction :: DelayedAction a -> IO (Barrier (Either SomeException a), DelayedActionInternal)
 instantiateDelayedAction (DelayedAction s p a) = do
   b <- newBarrier
-  let a' = do 
+  let a' = do
         -- work gets reenqueued when the Shake session is restarted
         -- it can happen that a work item finished just as it was reenqueud
         -- in that case, skipping the work is fine
@@ -1074,8 +1075,8 @@ type instance RuleResult GetModificationTime = FileVersion
 data FileVersion
     = VFSVersion !Int
     | ModificationTime
-      !Int   -- ^ Large unit (platform dependent, do not make assumptions)
-      !Int   -- ^ Small unit (platform dependent, do not make assumptions)
+      !Int64   -- ^ Large unit (platform dependent, do not make assumptions)
+      !Int64   -- ^ Small unit (platform dependent, do not make assumptions)
     deriving (Show, Generic)
 
 instance NFData FileVersion
@@ -1084,10 +1085,6 @@ vfsVersion :: FileVersion -> Maybe Int
 vfsVersion (VFSVersion i) = Just i
 vfsVersion ModificationTime{} = Nothing
 
-modificationTime :: FileVersion -> Maybe (Int, Int)
-modificationTime VFSVersion{} = Nothing
-modificationTime (ModificationTime large small) = Just (large, small)
-
 getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
 getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags