ghc-mod/Language/Haskell/GhcMod/Caching.hs
2015-08-11 07:38:25 +02:00

104 lines
3.8 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
module Language.Haskell.GhcMod.Caching (
module Language.Haskell.GhcMod.Caching
, module Language.Haskell.GhcMod.Caching.Types
) where
import Control.Arrow (first)
import Control.Monad
import Control.Monad.Trans.Maybe
import Data.Maybe
import Data.Serialize (Serialize, encode, decode)
import Data.Version
import Data.Label
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.Caching.Types
import Language.Haskell.GhcMod.Logging
-- | Cache a MonadIO action with proper invalidation.
cached :: forall m a d. (MonadIO m, GmLog m, GmState m, Serialize a, Eq d, Serialize d, Show d)
=> FilePath -- ^ Directory to prepend to 'cacheFile'
-> Cached m GhcModState 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)
case cacheLens cd of
Nothing -> return ()
Just label -> do
gmLog GmDebug "" $ (text "writing memory cache") <+>: text (cacheFile cd)
setLabel label $ Just (ifs', d, a)
liftIO $ BS.writeFile (dir </> cacheFile cd) $
BS.append cacheHeader $ encode (ifs', d, a)
return a
setLabel l x = do
s <- gmsGet
gmsPut $ set l x s
readCache :: m (Maybe ([FilePath], d, a))
readCache = runMaybeT $ do
case cacheLens cd of
Just label -> do
c <- MaybeT (get label `liftM` gmsGet) `mplus` readCacheFromFile
setLabel label $ Just c
return c
Nothing ->
readCacheFromFile
readCacheFromFile = do
f <- MaybeT $ liftIO $ mightExist $ cacheFile cd
readCacheFromFile' f
readCacheFromFile' f = MaybeT $ 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