121 lines
4.3 KiB
Haskell
121 lines
4.3 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
module Language.Haskell.GhcMod.Caching where
|
|
|
|
import Control.Arrow (first)
|
|
import Control.Monad.Trans.Maybe
|
|
import Data.Maybe
|
|
import Data.Serialize
|
|
import Data.Version
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.ByteString.Char8 as BS8
|
|
import System.FilePath
|
|
import Utils (TimedFile(..), timeMaybe, mightExist)
|
|
import Paths_ghc_mod (version)
|
|
|
|
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 to cache action. 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, Show 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 or unreadable"
|
|
Just (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 (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
|
|
cacheHeader = BS8.pack $ "Written by ghc-mod " ++ showVersion version ++ "\n"
|
|
|
|
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) $
|
|
BS.append cacheHeader $ 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
|
|
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 $ decode $ BS.drop 1 rest
|
|
_ -> return Nothing
|
|
|
|
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
|