Add modtime to on-disk and memory cache
This commit is contained in:
parent
758efc0be7
commit
82f33cdbd7
@ -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?
|
||||||
|
@ -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 {
|
||||||
|
Loading…
Reference in New Issue
Block a user