Prepare for splitting off ghc-mod-core eventually

core/Language/Haskell/GhcMod/Caching.hs

@@ -0,0 +1,141 @@
+-- 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