Check for in-memory cache invalidation (Fix #683)

Language/Haskell/GhcMod/Caching.hs

@@ -11,8 +11,9 @@ import Data.Maybe
 import Data.Binary (Binary, encode, decodeOrFail)
 import Data.Version
 import Data.Label
-import qualified Data.ByteString.Lazy as BS
+import qualified Data.ByteString.Lazy as LBS
-import qualified Data.ByteString.Lazy.Char8 as BS8
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
 import Data.Time (UTCTime, getCurrentTime)
 import System.FilePath
 import Utils (TimedFile(..), timeMaybe, mightExist)
@@ -30,25 +31,24 @@ cached :: forall m a d. (Gm m, MonadIO m, Binary a, Eq d, Binary d, Show d)
        -> m a
 cached dir cd d = do
     mcc <- readCache
-    tcfile <- liftIO $ timeMaybe (cacheFile cd)
     case mcc of
-      Nothing ->
+      Nothing -> do
-          writeCache (TimedCacheFiles tcfile []) Nothing "cache missing or unreadable"
+          t <- liftIO $ getCurrentTime
-      Just (_t, ifs, d', a) | d /= d' -> do
+          writeCache (TimedCacheFiles t []) Nothing "cache missing or unreadable"
-          tcf <- timeCacheInput dir (cacheFile cd) ifs
+      Just (t, ifs, d', a) | d /= d' -> do
-          writeCache tcf (Just a) $ "input data changed" -- ++ "   was: " ++ show d ++ "  is: " ++ show d'
+          tcfs <- timeCacheInput dir ifs
-      Just (_t, ifs, _, a) -> do
+          writeCache (TimedCacheFiles t tcfs) (Just a) $ "input data changed" -- ++ "   was: " ++ show d ++ "  is: " ++ show d'
-          tcf <- timeCacheInput dir (cacheFile cd) ifs
+      Just (t, ifs, _, a) -> do
-          case invalidatingInputFiles tcf of
+          tcfs <- timeCacheInput dir ifs
-            Just [] -> return a
+          case invalidatingInputFiles $ TimedCacheFiles t tcfs of
-            Just _  -> writeCache tcf (Just a) "input files changed"
+            [] -> return a
-            Nothing -> writeCache tcf (Just a) "cache missing, existed a sec ago WTF?"
+            _  -> writeCache (TimedCacheFiles t tcfs) (Just a) "input files changed"
 
  where
    cacheHeader = BS8.pack $ "Written by ghc-mod " ++ showVersion version ++ "\n"
 
-   writeCache tcf ma cause = do
+   writeCache tcfs ma cause = do
-     (ifs', a) <- (cachedAction cd) tcf d ma
+     (ifs', a) <- (cachedAction cd) tcfs d ma
      t <- liftIO $ getCurrentTime
      gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd)
                                                     <+> parens (text cause)
@@ -58,8 +58,10 @@ cached dir cd d = do
          gmLog GmDebug "" $ (text "writing memory cache") <+>: text (cacheFile cd)
          setLabel label $ Just (t, ifs', d, a)
 
-     liftIO $ BS.writeFile (dir </> cacheFile cd) $
+     let c = BS.append cacheHeader $ LBS.toStrict $ encode (t, ifs', d, a)
-         BS.append cacheHeader $ encode (t, ifs', d, a)
+
+     liftIO $ BS.writeFile (dir </> cacheFile cd) c
+
      return a
 
    setLabel l x = do
@@ -88,7 +90,8 @@ cached dir cd d = do
      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 $ decodeE $ BS.drop 1 rest
+            return $ either (const Nothing) Just $
+                decodeE $ LBS.fromStrict $ BS.drop 1 rest
        _ -> return Nothing
 
    decodeE b = do
@@ -96,17 +99,13 @@ cached dir cd d = do
        Left (_rest, _offset, errmsg) -> Left errmsg
        Right (_reset, _offset, a) -> Right a
 
-timeCacheInput :: MonadIO m => FilePath -> FilePath -> [FilePath] -> m TimedCacheFiles
+timeCacheInput :: MonadIO m => FilePath -> [FilePath] -> m [TimedFile]
-timeCacheInput dir cfile ifs = liftIO $ do
+timeCacheInput dir ifs = liftIO $ do
-    -- TODO: is checking the times this way around race free?
     ins <- (timeMaybe . (dir </>)) `mapM` ifs
-    mtcfile <- timeMaybe cfile
+    return $ catMaybes ins
-    return $ TimedCacheFiles mtcfile (catMaybes ins)
 
-invalidatingInputFiles :: TimedCacheFiles -> Maybe [FilePath]
+invalidatingInputFiles :: TimedCacheFiles -> [FilePath]
-invalidatingInputFiles tcf =
+invalidatingInputFiles (TimedCacheFiles tcreated tcfs) =
-    case tcCacheFile tcf of
+    map tfPath $
-      Nothing -> Nothing
+        -- get input files older than tcfile
-      Just tcfile -> Just $ map tfPath $
+        filter ((TimedFile "" tcreated)<) tcfs
-                     -- get input files older than tcfile
-                     filter (tcfile<) $ tcFiles tcf

Language/Haskell/GhcMod/Caching/Types.hs

@@ -43,7 +43,7 @@ data Cached m s d a = Cached {
  }
 
 data TimedCacheFiles = TimedCacheFiles {
-  tcCacheFile :: Maybe TimedFile,
+  tcCreated :: ModTime,
   -- ^ 'cacheFile' timestamp
   tcFiles     :: [TimedFile]
   -- ^ Timestamped files returned by the cached action

Language/Haskell/GhcMod/Target.hs

@@ -199,22 +199,21 @@ resolvedComponentsCache distdir = Cached {
     cacheFile = resolvedComponentsCacheFile distdir,
     cachedAction = \tcfs comps ma -> do
         Cradle {..} <- cradle
-        let iifsM = invalidatingInputFiles tcfs
+        let iifs = invalidatingInputFiles tcfs
+
+            setupChanged =
+                (cradleRootDir </> setupConfigPath distdir) `elem` iifs
+
             mums :: Maybe [Either FilePath ModuleName]
             mums =
-              case iifsM of
+              let
-                Nothing -> Nothing
+                  filterOutSetupCfg =
-                Just iifs ->
+                      filter (/= cradleRootDir </> setupConfigPath distdir)
-                  let
+                  changedFiles = filterOutSetupCfg iifs
-                      filterOutSetupCfg =
+              in if null changedFiles
-                          filter (/= cradleRootDir </> setupConfigPath distdir)
+                   then Nothing
-                      changedFiles = filterOutSetupCfg iifs
+                   else Just $ map Left changedFiles
-                  in if null changedFiles
+
-                       then Nothing
-                       else Just $ map Left changedFiles
-            setupChanged = maybe False
-                                 (elem $ cradleRootDir </> setupConfigPath distdir)
-                                 iifsM
         case (setupChanged, ma) of
           (False, Just mcs) -> gmsGet >>= \s -> gmsPut s { gmComponents = mcs }
           _ -> return ()