Fix resolved component caching

This commit is contained in:
Daniel Gröber 2015-04-12 02:39:18 +02:00
parent ca79f99c3e
commit 39a8ded102
3 changed files with 29 additions and 16 deletions

View File

@ -74,7 +74,7 @@ cabalHelperCache :: MonadIO m => Cached m
[GmComponent GMCRaw ChEntrypoint]
cabalHelperCache = Cached {
cacheFile = cabalHelperCacheFile,
cachedAction = \ _ (progs, root, _) ->
cachedAction = \ _ (progs, root, _) _ ->
runQuery' progs root $ do
q <- liftM5 join5
ghcOptions

View File

@ -5,6 +5,7 @@ import Data.Maybe
import Data.Serialize
import qualified Data.ByteString as BS
import System.FilePath
import Utils (TimedFile(..), timeMaybe, mightExist)
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Logging
@ -13,7 +14,7 @@ import Utils
data Cached m d a =
Cached { cacheFile :: FilePath,
cachedAction :: TimedCacheFiles -> d -> m ([FilePath], a)
cachedAction :: TimedCacheFiles -> d -> Maybe a -> m ([FilePath], a)
-- ^ The cached action, will only run if
-- * The cache doesn\'t exist yet
-- * The cache exists and 'inputData' changed
@ -37,21 +38,21 @@ cached dir cd d = do
let defTcf = TimedCacheFiles tcfile []
case mcc of
Nothing -> writeCache defTcf "cache missing"
Just (ifs, d', _) | d /= d' -> do
Nothing -> writeCache defTcf Nothing "cache missing"
Just (ifs, d', a) | d /= d' -> do
tcf <- timeCacheInput dir (cacheFile cd) ifs
writeCache tcf "input data changed"
writeCache tcf (Just a) "input data changed"
Just (ifs, _, a) -> do
tcf <- timeCacheInput dir (cacheFile cd) ifs
let invifs = invalidatingInputFiles tcf
case invifs of
Nothing -> writeCache tcf "cache missing, existed a sec ago WTF?"
Nothing -> writeCache tcf (Just a) "cache missing, existed a sec ago WTF?"
Just [] -> return a
Just _ -> writeCache tcf "input files changed"
Just _ -> writeCache tcf (Just a) "input files changed"
where
writeCache tcf cause = do
(ifs', a) <- (cachedAction cd) tcf d
writeCache tcf ma cause = do
(ifs', a) <- (cachedAction cd) tcf d ma
gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd)
<+> parens (text cause)
liftIO $ BS.writeFile (dir </> cacheFile cd) $ encode (ifs', d, a)

View File

@ -195,14 +195,26 @@ resolvedComponentsCache :: IOish m => Cached (GhcModT m)
(Map.Map ChComponentName (GmComponent GMCResolved (Set.Set ModulePath)))
resolvedComponentsCache = Cached {
cacheFile = resolvedComponentsCacheFile,
cachedAction = \tcfs comps -> do
cachedAction = \tcfs comps ma -> do
Cradle {..} <- cradle
let changedFiles =
filter (/= cradleRootDir </> setupConfigPath) $ map tfPath $ tcFiles tcfs
mums = if null changedFiles
let mums =
case invalidatingInputFiles tcfs of
Nothing -> Nothing
Just iifs ->
let
filterOutSetupCfg =
filter (/= cradleRootDir </> setupConfigPath)
changedFiles = filterOutSetupCfg iifs
in if null changedFiles
then Nothing
else Just $ map Left changedFiles
case ma of
Just mcs -> gmsGet >>= \s -> gmsPut s { gmComponents = mcs }
Nothing -> return ()
-- liftIO $ print ("changed files", mums :: Maybe [Either FilePath ()])
mcs <- resolveGmComponents mums comps
return (setupConfigPath:flatten mcs , mcs)
}