ghc-mod/Language/Haskell/GhcMod/Caching.hs
2015-06-07 02:44:11 +02:00

109 lines
3.7 KiB
Haskell

module Language.Haskell.GhcMod.Caching where
import Control.Monad.Trans.Maybe
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
data Cached m d a = Cached {
cacheFile :: FilePath,
cachedAction :: TimedCacheFiles
-> d
-> Maybe a
-> m ([FilePath], a)
-- ^ @cachedAction tcf data ma@
--
-- * @tcf@: Input file timestamps. Not technically necessary, just an
-- optimizazion when knowing which input files changed can make updating the
-- cache faster
--
-- * @data@: Arbitrary static input data can be used to invalidate the cache
-- using something other than file timestamps i.e. environment tool version
-- numbers
--
-- * @ma@: Cached data if it existed
--
-- Returns:
--
-- * @fst@: Input files used in generating the cache
--
-- * @snd@: Cache data, will be stored alongside the static input data in the
-- 'cacheFile'
--
-- The cached action, will only run if one of the following is true:
--
-- * 'cacheFile' doesn\'t exist yet
-- * 'cacheFile' exists and 'inputData' changed
-- * any files returned by the cached action changed
}
data TimedCacheFiles = TimedCacheFiles {
tcCacheFile :: Maybe TimedFile,
-- ^ 'cacheFile' timestamp
tcFiles :: [TimedFile]
-- ^ Timestamped files returned by the cached action
}
-- | Cache a MonadIO action with proper invalidation.
cached :: forall m a d. (MonadIO m, GmLog m, Serialize a, Eq d, Serialize d)
=> FilePath -- ^ Directory to prepend to 'cacheFile'
-> Cached m d a -- ^ Cache descriptor
-> 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"
Just (ifs, d', a) | d /= d' -> do
tcf <- timeCacheInput dir (cacheFile cd) ifs
writeCache tcf (Just a) "input data changed"
Just (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?"
where
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)
return a
readCache :: m (Maybe ([FilePath], d, a))
readCache = runMaybeT $ do
f <- MaybeT $ liftIO $ mightExist $ cacheFile cd
MaybeT $ readCache' f
where
readCache' f = do
gmLog GmDebug "" $ (text "reading cache") <+>: text (cacheFile cd)
cc <- liftIO $ BS.readFile f
return $ either (const Nothing) Just $ decode cc
timeCacheInput :: MonadIO m => FilePath -> FilePath -> [FilePath] -> m TimedCacheFiles
timeCacheInput dir cfile ifs = liftIO $ do
-- TODO: is checking the times this way around race free?
ins <- (timeMaybe . (dir </>)) `mapM` ifs
mtcfile <- timeMaybe cfile
return $ TimedCacheFiles mtcfile (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