ghc-mod/core/Language/Haskell/GhcMod/Caching.hs
2017-01-12 17:05:47 +01:00

142 lines
5.0 KiB
Haskell

-- ghc-mod: Making Haskell development *more* fun
-- 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 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
#if !MIN_VERSION_binary(0,7,0)
import Control.Exception
#endif
import Data.Maybe
import Data.Binary hiding (get)
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
import Utils (TimedFile(..), timeMaybe, mightExist)
import Paths_ghc_mod (version)
import Prelude
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. (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
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