ghc-mod/core/GhcMod/Caching.hs

142 lines
4.9 KiB
Haskell
Raw Normal View History

2017-03-06 23:19:57 +00:00
-- ghc-mod: Happy Haskell Hacking
2015-11-26 14:03:14 +00:00
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP, OverloadedStrings #-}
module GhcMod.Caching (
module GhcMod.Caching
, module GhcMod.Caching.Types
) where
2015-08-10 03:00:58 +00:00
import Control.Arrow (first)
import Control.Monad
import Control.Monad.Trans.Maybe
#if !MIN_VERSION_binary(0,7,0)
import Control.Exception
#endif
import Data.Maybe
import Data.Binary hiding (get)
2015-08-10 03:00:58 +00:00
import Data.Version
import Data.Label
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import System.FilePath
import System.Directory.ModTime
2015-04-12 00:39:18 +00:00
import Utils (TimedFile(..), timeMaybe, mightExist)
import Paths_ghc_mod_core (version)
import Prelude
import GhcMod.Monad.Types
import GhcMod.Caching.Types
import GhcMod.Logging
-- | Cache a MonadIO action with proper invalidation.
cached :: forall m a d. (Gm m, MonadIO m, Binary a, Eq d, Binary 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
case mcc of
Nothing -> do
t <- liftIO $ getCurrentModTime
writeCache (TimedCacheFiles t []) Nothing "cache missing or unreadable"
Just (t, ifs, d', a) | d /= d' -> do
tcfs <- timeCacheInput dir ifs
writeCache (TimedCacheFiles t tcfs) (Just a) $ "input data changed" -- ++ " was: " ++ show d ++ " is: " ++ show d'
Just (t, ifs, _, a) -> do
tcfs <- timeCacheInput dir ifs
case invalidatingInputFiles $ TimedCacheFiles t tcfs of
[] -> return a
_ -> writeCache (TimedCacheFiles t tcfs) (Just a) "input files changed"
where
2015-08-10 03:00:58 +00:00
cacheHeader = BS8.pack $ "Written by ghc-mod " ++ showVersion version ++ "\n"
lbsToStrict = BS.concat . LBS.toChunks
lbsFromStrict bs = LBS.fromChunks [bs]
writeCache tcfs ma cause = do
(ifs', a) <- (cachedAction cd) tcfs d ma
t <- liftIO $ getCurrentModTime
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 (t, ifs', d, a)
let c = BS.append cacheHeader $ lbsToStrict $ encode (t, ifs', d, a)
liftIO $ BS.writeFile (dir </> cacheFile cd) c
return a
setLabel l x = do
s <- gmsGet
gmsPut $ set l x s
readCache :: m (Maybe (ModTime, [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 :: MaybeT m (ModTime, [FilePath], d, a)
readCacheFromFile = do
f <- MaybeT $ liftIO $ mightExist $ cacheFile cd
readCacheFromFile' f
readCacheFromFile' :: FilePath -> MaybeT m (ModTime, [FilePath], d, a)
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 ->
either (const Nothing) Just
`liftM` decodeE (lbsFromStrict $ BS.drop 1 rest)
_ -> return Nothing
decodeE b = do
#if MIN_VERSION_binary(0,7,0)
return $ case decodeOrFail b of
Left (_rest, _offset, errmsg) -> Left errmsg
Right (_reset, _offset, a) -> Right a
#else
ea <- liftIO $ try $ evaluate $ decode b
return $ case ea of
Left (ErrorCall errmsg) -> Left errmsg
Right a -> Right a
#endif
timeCacheInput :: MonadIO m => FilePath -> [FilePath] -> m [TimedFile]
timeCacheInput dir ifs = liftIO $ do
ins <- (timeMaybe . (dir </>)) `mapM` ifs
return $ catMaybes ins
invalidatingInputFiles :: TimedCacheFiles -> [FilePath]
invalidatingInputFiles (TimedCacheFiles tcreated tcfs) =
map tfPath $
-- get input files older than tcfile
filter ((TimedFile "" tcreated)<) tcfs