hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix resolved component caching

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Language/Haskell/GhcMod/CabalHelper.hs
View File

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

17
Language/Haskell/GhcMod/Caching.hs
View File

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

26
Language/Haskell/GhcMod/Target.hs
View File

@ -191,17 +191,29 @@ targetGhcOptions crdl sefnmn = do
return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs
resolvedComponentsCache :: IOish m => Cached (GhcModT m) resolvedComponentsCache :: IOish m => Cached (GhcModT m)
[GmComponent GMCRaw(Set.Set ModulePath)] [GmComponent GMCRaw (Set.Set ModulePath)]
(Map.Map ChComponentName (GmComponent GMCResolved (Set.Set ModulePath))) (Map.Map ChComponentName (GmComponent GMCResolved (Set.Set ModulePath)))
resolvedComponentsCache = Cached { resolvedComponentsCache = Cached {
cacheFile = resolvedComponentsCacheFile, cacheFile = resolvedComponentsCacheFile,
cachedAction = \tcfs comps -> do cachedAction = \tcfs comps ma -> do
Cradle {..} <- cradle Cradle {..} <- cradle
let changedFiles = let mums =
filter (/= cradleRootDir </> setupConfigPath) $ map tfPath $ tcFiles tcfs case invalidatingInputFiles tcfs of
mums = if null changedFiles Nothing -> Nothing
then Nothing Just iifs ->
else Just $ map Left changedFiles 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 mcs <- resolveGmComponents mums comps
return (setupConfigPath:flatten mcs , mcs) return (setupConfigPath:flatten mcs , mcs)