83 lines
3.1 KiB
Haskell
83 lines
3.1 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)
|
|
-- ^ The cached action, will only run if
|
|
-- * The cache doesn\'t exist yet
|
|
-- * The cache exists and 'inputData' changed
|
|
-- * any files in 'inputFiles' are older than 'cacheFile'.
|
|
}
|
|
|
|
data TimedCacheFiles =
|
|
TimedCacheFiles { tcCacheFile :: Maybe TimedFile,
|
|
tcFiles :: [TimedFile]
|
|
}
|
|
|
|
-- | 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)
|
|
let defTcf = TimedCacheFiles tcfile []
|
|
|
|
case mcc of
|
|
Nothing -> writeCache defTcf 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
|
|
let invifs = invalidatingInputFiles tcf
|
|
case invifs of
|
|
Nothing -> writeCache tcf (Just a) "cache missing, existed a sec ago WTF?"
|
|
Just [] -> return a
|
|
Just _ -> writeCache tcf (Just a) "input files changed"
|
|
|
|
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
|