diff --git a/Language/Haskell/GhcMod/Caching.hs b/Language/Haskell/GhcMod/Caching.hs index bd11dde..33bf232 100644 --- a/Language/Haskell/GhcMod/Caching.hs +++ b/Language/Haskell/GhcMod/Caching.hs @@ -11,8 +11,9 @@ import Data.Maybe import Data.Binary (Binary, encode, decodeOrFail) import Data.Version import Data.Label -import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Lazy.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 import Data.Time (UTCTime, getCurrentTime) import System.FilePath import Utils (TimedFile(..), timeMaybe, mightExist) @@ -30,25 +31,24 @@ cached :: forall m a d. (Gm m, MonadIO m, Binary a, Eq d, Binary d, Show d) -> m a cached dir cd d = do mcc <- readCache - tcfile <- liftIO $ timeMaybe (cacheFile cd) case mcc of - Nothing -> - writeCache (TimedCacheFiles tcfile []) Nothing "cache missing or unreadable" - Just (_t, ifs, d', a) | d /= d' -> do - tcf <- timeCacheInput dir (cacheFile cd) ifs - writeCache tcf (Just a) $ "input data changed" -- ++ " was: " ++ show d ++ " is: " ++ show d' - Just (_t, ifs, _, a) -> do - tcf <- timeCacheInput dir (cacheFile cd) ifs - case invalidatingInputFiles tcf of - Just [] -> return a - Just _ -> writeCache tcf (Just a) "input files changed" - Nothing -> writeCache tcf (Just a) "cache missing, existed a sec ago WTF?" + Nothing -> do + t <- liftIO $ getCurrentTime + writeCache (TimedCacheFiles t []) Nothing "cache missing or unreadable" + Just (t, ifs, d', a) | d /= d' -> do + tcfs <- timeCacheInput dir ifs + writeCache (TimedCacheFiles t tcfs) (Just a) $ "input data changed" -- ++ " was: " ++ show d ++ " is: " ++ show d' + Just (t, ifs, _, a) -> do + tcfs <- timeCacheInput dir ifs + case invalidatingInputFiles $ TimedCacheFiles t tcfs of + [] -> return a + _ -> writeCache (TimedCacheFiles t tcfs) (Just a) "input files changed" where cacheHeader = BS8.pack $ "Written by ghc-mod " ++ showVersion version ++ "\n" - writeCache tcf ma cause = do - (ifs', a) <- (cachedAction cd) tcf d ma + writeCache tcfs ma cause = do + (ifs', a) <- (cachedAction cd) tcfs d ma t <- liftIO $ getCurrentTime gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd) <+> parens (text cause) @@ -58,8 +58,10 @@ cached dir cd d = do gmLog GmDebug "" $ (text "writing memory cache") <+>: text (cacheFile cd) setLabel label $ Just (t, ifs', d, a) - liftIO $ BS.writeFile (dir cacheFile cd) $ - BS.append cacheHeader $ encode (t, ifs', d, a) + let c = BS.append cacheHeader $ LBS.toStrict $ encode (t, ifs', d, a) + + liftIO $ BS.writeFile (dir cacheFile cd) c + return a setLabel l x = do @@ -88,7 +90,8 @@ cached dir cd d = do case first BS8.words $ BS8.span (/='\n') cc of (["Written", "by", "ghc-mod", ver], rest) | BS8.unpack ver == showVersion version -> - return $ either (const Nothing) Just $ decodeE $ BS.drop 1 rest + return $ either (const Nothing) Just $ + decodeE $ LBS.fromStrict $ BS.drop 1 rest _ -> return Nothing decodeE b = do @@ -96,17 +99,13 @@ cached dir cd d = do Left (_rest, _offset, errmsg) -> Left errmsg Right (_reset, _offset, a) -> Right a -timeCacheInput :: MonadIO m => FilePath -> FilePath -> [FilePath] -> m TimedCacheFiles -timeCacheInput dir cfile ifs = liftIO $ do - -- TODO: is checking the times this way around race free? +timeCacheInput :: MonadIO m => FilePath -> [FilePath] -> m [TimedFile] +timeCacheInput dir ifs = liftIO $ do ins <- (timeMaybe . (dir )) `mapM` ifs - mtcfile <- timeMaybe cfile - return $ TimedCacheFiles mtcfile (catMaybes ins) + return $ catMaybes ins -invalidatingInputFiles :: TimedCacheFiles -> Maybe [FilePath] -invalidatingInputFiles tcf = - case tcCacheFile tcf of - Nothing -> Nothing - Just tcfile -> Just $ map tfPath $ - -- get input files older than tcfile - filter (tcfile<) $ tcFiles tcf +invalidatingInputFiles :: TimedCacheFiles -> [FilePath] +invalidatingInputFiles (TimedCacheFiles tcreated tcfs) = + map tfPath $ + -- get input files older than tcfile + filter ((TimedFile "" tcreated)<) tcfs diff --git a/Language/Haskell/GhcMod/Caching/Types.hs b/Language/Haskell/GhcMod/Caching/Types.hs index 473bff5..2524c83 100644 --- a/Language/Haskell/GhcMod/Caching/Types.hs +++ b/Language/Haskell/GhcMod/Caching/Types.hs @@ -43,7 +43,7 @@ data Cached m s d a = Cached { } data TimedCacheFiles = TimedCacheFiles { - tcCacheFile :: Maybe TimedFile, + tcCreated :: ModTime, -- ^ 'cacheFile' timestamp tcFiles :: [TimedFile] -- ^ Timestamped files returned by the cached action diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 431fc5d..e622dd5 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -199,22 +199,21 @@ resolvedComponentsCache distdir = Cached { cacheFile = resolvedComponentsCacheFile distdir, cachedAction = \tcfs comps ma -> do Cradle {..} <- cradle - let iifsM = invalidatingInputFiles tcfs + let iifs = invalidatingInputFiles tcfs + + setupChanged = + (cradleRootDir setupConfigPath distdir) `elem` iifs + mums :: Maybe [Either FilePath ModuleName] mums = - case iifsM of - Nothing -> Nothing - Just iifs -> - let - filterOutSetupCfg = - filter (/= cradleRootDir setupConfigPath distdir) - changedFiles = filterOutSetupCfg iifs - in if null changedFiles - then Nothing - else Just $ map Left changedFiles - setupChanged = maybe False - (elem $ cradleRootDir setupConfigPath distdir) - iifsM + let + filterOutSetupCfg = + filter (/= cradleRootDir setupConfigPath distdir) + changedFiles = filterOutSetupCfg iifs + in if null changedFiles + then Nothing + else Just $ map Left changedFiles + case (setupChanged, ma) of (False, Just mcs) -> gmsGet >>= \s -> gmsPut s { gmComponents = mcs } _ -> return ()