Add modtime to on-disk and memory cache

This commit is contained in:
Daniel Gröber 2015-11-18 20:58:29 +01:00
parent 758efc0be7
commit 82f33cdbd7
2 changed files with 12 additions and 6 deletions

View File

@ -13,6 +13,7 @@ import Data.Version
import Data.Label import Data.Label
import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BS8 import qualified Data.ByteString.Lazy.Char8 as BS8
import Data.Time (UTCTime, getCurrentTime)
import System.FilePath import System.FilePath
import Utils (TimedFile(..), timeMaybe, mightExist) import Utils (TimedFile(..), timeMaybe, mightExist)
import Paths_ghc_mod (version) import Paths_ghc_mod (version)
@ -33,10 +34,10 @@ cached dir cd d = do
case mcc of case mcc of
Nothing -> Nothing ->
writeCache (TimedCacheFiles tcfile []) Nothing "cache missing or unreadable" writeCache (TimedCacheFiles tcfile []) Nothing "cache missing or unreadable"
Just (ifs, d', a) | d /= d' -> do Just (_t, ifs, d', a) | d /= d' -> do
tcf <- timeCacheInput dir (cacheFile cd) ifs tcf <- timeCacheInput dir (cacheFile cd) ifs
writeCache tcf (Just a) $ "input data changed" -- ++ " was: " ++ show d ++ " is: " ++ show d' writeCache tcf (Just a) $ "input data changed" -- ++ " was: " ++ show d ++ " is: " ++ show d'
Just (ifs, _, a) -> do Just (_t, ifs, _, a) -> do
tcf <- timeCacheInput dir (cacheFile cd) ifs tcf <- timeCacheInput dir (cacheFile cd) ifs
case invalidatingInputFiles tcf of case invalidatingInputFiles tcf of
Just [] -> return a Just [] -> return a
@ -48,23 +49,24 @@ cached dir cd d = do
writeCache tcf ma cause = do writeCache tcf ma cause = do
(ifs', a) <- (cachedAction cd) tcf d ma (ifs', a) <- (cachedAction cd) tcf d ma
t <- liftIO $ getCurrentTime
gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd) gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd)
<+> parens (text cause) <+> parens (text cause)
case cacheLens cd of case cacheLens cd of
Nothing -> return () Nothing -> return ()
Just label -> do Just label -> do
gmLog GmDebug "" $ (text "writing memory cache") <+>: text (cacheFile cd) gmLog GmDebug "" $ (text "writing memory cache") <+>: text (cacheFile cd)
setLabel label $ Just (ifs', d, a) setLabel label $ Just (t, ifs', d, a)
liftIO $ BS.writeFile (dir </> cacheFile cd) $ liftIO $ BS.writeFile (dir </> cacheFile cd) $
BS.append cacheHeader $ encode (ifs', d, a) BS.append cacheHeader $ encode (t, ifs', d, a)
return a return a
setLabel l x = do setLabel l x = do
s <- gmsGet s <- gmsGet
gmsPut $ set l x s gmsPut $ set l x s
readCache :: m (Maybe ([FilePath], d, a)) readCache :: m (Maybe (UTCTime, [FilePath], d, a))
readCache = runMaybeT $ do readCache = runMaybeT $ do
case cacheLens cd of case cacheLens cd of
Just label -> do Just label -> do
@ -74,10 +76,12 @@ cached dir cd d = do
Nothing -> Nothing ->
readCacheFromFile readCacheFromFile
readCacheFromFile :: MaybeT m (UTCTime, [FilePath], d, a)
readCacheFromFile = do readCacheFromFile = do
f <- MaybeT $ liftIO $ mightExist $ cacheFile cd f <- MaybeT $ liftIO $ mightExist $ cacheFile cd
readCacheFromFile' f readCacheFromFile' f
readCacheFromFile' :: FilePath -> MaybeT m (UTCTime, [FilePath], d, a)
readCacheFromFile' f = MaybeT $ do readCacheFromFile' f = MaybeT $ do
gmLog GmDebug "" $ (text "reading cache") <+>: text (cacheFile cd) gmLog GmDebug "" $ (text "reading cache") <+>: text (cacheFile cd)
cc <- liftIO $ BS.readFile f cc <- liftIO $ BS.readFile f
@ -91,6 +95,7 @@ cached dir cd d = do
case decodeOrFail b of case decodeOrFail b of
Left (_rest, _offset, errmsg) -> Left errmsg Left (_rest, _offset, errmsg) -> Left errmsg
Right (_reset, _offset, a) -> Right a Right (_reset, _offset, a) -> Right a
timeCacheInput :: MonadIO m => FilePath -> FilePath -> [FilePath] -> m TimedCacheFiles timeCacheInput :: MonadIO m => FilePath -> FilePath -> [FilePath] -> m TimedCacheFiles
timeCacheInput dir cfile ifs = liftIO $ do timeCacheInput dir cfile ifs = liftIO $ do
-- TODO: is checking the times this way around race free? -- TODO: is checking the times this way around race free?

View File

@ -2,9 +2,10 @@ module Language.Haskell.GhcMod.Caching.Types where
import Utils import Utils
import Data.Label import Data.Label
import Data.Time (UTCTime)
import Distribution.Helper import Distribution.Helper
type CacheContents d a = Maybe ([FilePath], d, a) type CacheContents d a = Maybe (UTCTime, [FilePath], d, a)
type CacheLens s d a = s :-> CacheContents d a type CacheLens s d a = s :-> CacheContents d a
data Cached m s d a = Cached { data Cached m s d a = Cached {